perm filename INTER.LSP[NEW,LSP] blob
sn#544591 filedate 1980-11-18 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00183 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00006 00002 <NEWLISP>LISP.MAC.2, 6-Jun-80 11:14:03, Edit by LEWIS
C00056 00003
C00058 00004
C00060 00005
C00063 00006
C00065 00007
C00067 00008
C00069 00009
C00072 00010
C00075 00011
C00077 00012
C00081 00013 UUO-CALLED ROUTINES
C00083 00014
C00084 00015
C00086 00016
C00088 00017
C00090 00018
C00092 00019
C00094 00020
C00097 00021
C00103 00022
C00108 00023
C00113 00024
C00117 00025
C00121 00026
C00126 00027
C00131 00028
C00136 00029
C00138 00030
C00141 00031
C00144 00032 SET KL20 FLAG AND TRY TO GET A RELEASE NUMBER
C00146 00033 RESETE: SETOM NOFLG
C00149 00034
C00151 00035
C00155 00036
C00159 00037
C00160 00038
C00162 00039
C00168 00040
C00171 00041
C00174 00042
C00176 00043
C00178 00044
C00182 00045
C00183 00046
C00186 00047
C00187 00048
C00191 00049
C00194 00050
C00196 00051
C00198 00052
C00200 00053
C00202 00054
C00204 00055
C00206 00056
C00207 00057
C00209 00058
C00211 00059
C00212 00060
C00213 00061
C00215 00062
C00218 00063
C00221 00064
C00226 00065
C00228 00066
C00229 00067
C00231 00068
C00233 00069
C00234 00070
C00236 00071
C00239 00072
C00242 00073
C00243 00074
C00246 00075
C00250 00076
C00255 00077
C00259 00078
C00260 00079
C00262 00080
C00264 00081
C00265 00082
C00267 00083
C00271 00084
C00274 00085
C00276 00086
C00278 00087
C00279 00088 IEQP: CALL I2UBOX
C00282 00089
C00285 00090
C00287 00091
C00290 00092
C00292 00093
C00294 00094
C00296 00095
C00298 00096
C00300 00097
C00301 00098
C00304 00099
C00307 00100
C00309 00101
C00313 00102
C00316 00103
C00318 00104
C00320 00105 GENERAL UNBOX- GET VALUE IN 1, TYPE IN 2
C00322 00106
C00326 00107
C00328 00108
C00331 00109
C00333 00110
C00335 00111
C00336 00112
C00338 00113
C00340 00114
C00347 00115
C00348 00116
C00350 00117
C00351 00118
C00353 00119
C00355 00120
C00357 00121
C00360 00122
C00362 00123
C00364 00124
C00365 00125
C00366 00126
C00367 00127
C00371 00128
C00373 00129
C00374 00130
C00377 00131
C00378 00132
C00379 00133
C00381 00134
C00384 00135
C00385 00136
C00389 00137
C00390 00138
C00394 00139
C00402 00140
C00405 00141
C00411 00142
C00414 00143 READ STRING
C00416 00144
C00418 00145 CONTROL - MISCELLANEOUS MODES FOR TTY INPUT
C00421 00146
C00424 00147
C00429 00148
C00434 00149
C00438 00150
C00440 00151
C00442 00152
C00444 00153
C00446 00154
C00448 00155
C00450 00156
C00454 00157
C00456 00158
C00459 00159
C00461 00160
C00466 00161
C00467 00162
C00474 00163
C00478 00164
C00479 00165
C00482 00166
C00485 00167
C00487 00168
C00489 00169
C00492 00170
C00498 00171
C00501 00172
C00503 00173
C00507 00174
C00525 00175 ONE-SHOT INIT, .START OR LISP0$G FROM DDT AFTER LOADING
C00529 00176
C00531 00177
C00533 00178
C00535 00179
C00538 00180
C00542 00181
C00544 00182
C00545 00183
C00546 ENDMK
C⊗;
;<NEWLISP>LISP.MAC.2, 6-Jun-80 11:14:03, Edit by LEWIS
; fix bug in character caused by instalation of NTHCHARCODE
;[BBN-TENEXD]<LEWIS>LISP.MAC.13, 22-Feb-80 00:19:36, Ed: LEWIS
; set the error number in control-e for warren
; fix bug in hard user interrupts
;<LEWIS>LISP.MAC.9, 4-Feb-80 16:35:10, Edit by LEWIS
; check in errorm and errorstring for error number out of range
;<LEWIS>LISP.MAC.8, 31-Jan-80 14:52:30, Edit by LEWIS
; install new error codes for warren
;<LEWIS>LISP.MAC.6, 21-Jan-80 10:53:37, Edit by LEWIS
; install GNCCODE, GLCCODE, NTHCHARCODE
;<LEWIS>LISP.MAC.5, 17-Oct-79 13:52:33, Edit by LEWIS
; fix to turn off soft interrupts when interrupts are off
;<NEWLISP>LISP.MAC.3, 12-Sep-79 16:52:24, Edit by LEWIS
; fix another bug in seta/clink
; Install tops20 version number stuff
; Fix bug in setalink - note: this counts in next contract
;[BBN-TENEXD]<NEWLISP>LISP.MAC.1, 24-Jul-79 13:24:38, Ed: LEWIS
; fixed CANT OPEN LISPMF bug of release 3.
;[BBN-TENEXD]<LEWIS>LISP.MAC.4, 11-May-79 14:32:42, Ed: LEWIS
; put in fix to NLGO to allow saying how many things to flush
; install Alice's fix to cp overflow.
; put in TERPRICNT for warren
;[BBN-TENEXD]<LEWIS>LISP.MAC.1, 2-Mar-79 11:26:27, Ed: LEWIS
; fix get/setfileptr to give correct on "illegal arg" error
;<NEWLISP>LISP.MAC;3 24-FEB-79 16:41:48 EDIT BY MASINTER
; put CTRLC in IFNDEF MAXC
;[BBN-TENEXD]<NEWLISP>LISP.MAC.14, 17-Jan-79 10:39:25, Ed: LEWIS
; Added TIGHTGC to tighten up loading of large systems
;[BBN-TENEXD]<NEWLISP>LISP.MAC.13, 7-Jan-79 23:02:01, Ed: LEWIS
; change prog1 so dwim can operate on the 1st arg safely
;<NEWLISP>LISP.MAC;5 5-JAN-79 05:56:45 EDIT BY MASINTER
; init DADDYN so that SYSOUT without MAKESYS will work
;[BBN-TENEXD]<NEWLISP>LISP.MAC.10, 4-Jan-79 11:01:12, Ed: LEWIS
; added EOFP for Peter.
;[BBN-TENEXD]<NEWLISP>LISP.MAC.8, 14-Dec-78 14:47:43, Ed: LEWIS
; fix setalink and setclink to get the RIGHT half of 2nd arg (no MOVE).
;[BBN-TENEXD]<NEWLISP>LISP.MAC.7, 14-Dec-78 10:08:25, Ed: LEWIS
; ADDED COREVALS TO GET TO THE ATOM MAKER
;[BBN-TENEXD]<LEWIS>LISP.MAC.1, 30-Oct-78 09:30:49, Ed: LEWIS
; USE STANDART FLOAT OUTPUT FORMAT IN IPRE (FOR THINGS LIKE PACK)
;[BBN-TENEXD]<LEWIS>LISP.MAC.2, 17-Oct-78 16:18:41, Ed: LEWIS
; PUT IN SETALINK AND SETCLINK
;<NEWLISP>LISP.MAC;101 2-OCT-78 00:48:59 EDIT BY MASINTER
; fix SYSOUT when page 777 is mapped
;<MASINTER>LISP.MAC;1 2-OCT-78 00:12:05 EDIT BY MASINTER
; fix MINFS to use 25 if given number too small (rather than do nothing)
;<NEWLISP>LISP.MAC;97 27-SEP-78 02:02:47 EDIT BY MASINTER
; fix bug in TRAP handler. Make DATA ERROR trap
;<NEWLISP>LISP.MAC;93 25-SEP-78 22:40:40 EDIT BY MASINTER
; fix CLRHASH to return arg always
;<NEWLISP>LISP.MAC;91 25-SEP-78 17:41:04 EDIT BY MASINTER
; look for JUMP after illegal instruction trap
;<NEWLISP>LISP.MAC;86 9-SEP-78 00:10:57 EDIT BY MASINTER
; allow SET(NIL NIL). Dont allow SET(T NIL)
;<NEWLISP>LISP.MAC;13 27-AUG-78 15:27:53 EDIT BY MASINTER
; set up COREVALs at LISP0 time.
;<NEWLISP>LISP.MAC;9 25-AUG-78 16:28:14 EDIT BY MASINTER
; add corevals for COPYSTRING and PRINTSTRING. Add ifdef's for later Maxc additions.
;[BBN-TENEXD]<LEWIS>LISP.MAC.1, 26-Jul-78 12:46:59, Ed: LEWIS
; ADDED ARGPRINTFN TO BACKTRACE FOR WARREN
; NORMALIZE FLTPT NUMS BEFORE PRINTING FOR KAPLAN
;<MASINTER>LISP.MAC;1 11-JUL-78 00:28:07 EDIT BY MASINTER
; install TYPENAME and HARRAYP as subrs; TYPENAME as COREVAL
;<MASINTER>LISP.MAC;5 2-JUL-78 03:38:27 EDIT BY MASINTER
; add CLISPARRAY to EVAL
;<NEWLISP>LISP.MAC;2 29-JUN-78 15:25:56 EDIT BY MASINTER
; change GCGAG to GCMESS
;[BBN-TENEXD]<NEWLISP>LISP.MAC.40, 8-Jul-78 16:20:54, Ed: HARTLEY
;INCREASED EMERGENCY STACK
;[BBN-TENEXD]<NEWLISP>LISP.MAC.38, 30-Jun-78 23:34:44, Ed: HARTLEY
;[BBN-TENEXD]<NEWLISP>LISP.MAC.37, 30-Jun-78 22:37:41, Ed: HARTLEY
;[BBN-TENEXD]<NEWLISP>LISP.MAC.36, 30-Jun-78 22:32:49, Ed: HARTLEY
;FIX BUG IN ECOPCO/ICPFUL
;[BBN-TENEXD]<NEWLISP>LISP.MAC.35, 30-Jun-78 17:13:14, Ed: HARTLEY
;FIX POTENTIAL INTERRUPT PROBLEM IN RELSTK
;[BBN-TENEXD]<NEWLISP>LISP.MAC.34, 19-Jun-78 13:28:18, Ed: LEWIS
; AVBLIP IN PROG1
;[BBN-TENEXD]<NEWLISP>LISP.MAC.33, 15-Jun-78 14:44:19, Ed: LEWIS
;<NEWLISP>LISP.MAC;33 8-JUN-78 13:14:15 EDIT BY MASINTER
; wrap stack allocation in IFNDEF's for SRI
;<NEWLISP>LISP.MAC;29 5-JUN-78 14:01:28 EDIT BY MASINTER
; make HARRAY a subr. Fix ERRORX call from PUTHASH to give original
; arg. Several other hash bug fixes.
;[BBN-TENEXD]<LEWIS>LISP.MAC.2, 2-Jun-78 00:37:37, Ed: LEWIS
; FIX BAD SYSIN PROBLEM, CHANGE ERROR MESSAGE
; MAKE ERROR 54Q BE 43Q TO FILL IN GAP
;[BBN-TENEXD]<LEWIS>LISP.MAC.6, 31-May-78 23:16:06, Ed: LEWIS
; Put in larry's rewrite of hash stuff
;[BBN-TENEXD]<LEWIS>LISP.MAC.2, 23-May-78 23:19:21, Ed: LEWIS
; Add array check to gethash, init syshasharray only on puthash
; Make initial value of syshasharray be NIL.
;[BBN-TENEXD]<LEWIS>LISP.MAC.1, 15-May-78 21:42:11, Ed: LEWIS
; New User Hash algorithm
;[BBN-TENEXD]<LEWIS>LISP.MAC.5, 1-May-78 14:54:30, EDIT BY LEWIS
; fix bug in float print
;<NEWLISP>LISP.MAC;1 26-APR-78 14:51:23 EDIT BY MASINTER
; remove IFNDEF MAXC from around REWIND & UNWIND
;<LEWIS>LISP.MAC.3 26-Apr-78 13:14:08 EDIT BY LEWIS
; fix a bug in PPRC
; fix empty result bug in DATE
;<NEWLISP>LISP.MAC;5 21-APR-78 00:19:12 EDIT BY MASINTER
; insert IFDEF MAXC patches for UNWIND and REWIND calls
;<LEWIS>LISP.MAC.15 18-Apr-78 23:37:45 EDIT BY LEWIS
; tighten readtable check by adding box word of 0,,0 to the end
; fix up margin check when printing
; make unwinding of frames be reverse order of binding
; fix INFILE and INPUT of a string
;<LEWIS>LISP.MAC.7 13-Apr-78 11:55:13 EDIT BY LEWIS
; do PROG1 when evaling SETQ
; demand that MINFS setting be at least 25
; in both prog and exprs, disallow binding NIL or T
; in exprs: make sure arg names are litatoms
; in PROG: make sure vars are litatoms and do PROG1 on init. vals.
; fix SETTOPVAL to check 1st arg for atom and non-NIL.
;<LEWIS>LISP.MAC.13 7-Apr-78 15:27:10 EDIT BY LEWIS
; fix BKSYSBUF and BKLINBUF to return argument as value.
; Add superdribble, allows edit chars to be dribbled.
;<NEWLISP>LISP.MAC;2 17-FEB-78 12:41:41 EDIT BY MASINTER
;FIX SWAPPER BUG AT CFRAM1
;<NEWLISP>LISP.MAC.20 3-Jan-78 22:09:10 EDIT BY LEWIS
;FIX BUG IN READING NULLS, MAKE NULL A SEPR IN READTABLES
;ADD THIRD ARG TO OPENF (GTJFN BITS) - ADD SETSTKNAME
;<NEWLISP>XLISP.MAC.10 6-Oct-77 23:49:16 EDIT BY HARTLEY
;FIX BUG IN CONCAT
;FIX SO NULLS GET THRU - HAVE CHANGED FCHAR=-1 => NO CHAR
;SORT OUT MORE GTJFN ERRORS, DONT CLOSE FILE ON EOF ERROR
;FIX STACK BUG RE CLEARING HOLE MARKS ON PP, FIX RPLSTRING, ADD PACK*
;<NEWLISP>XLISP.MAC.3 25-Aug-77 15:55:13 EDIT BY HARTLEY
;MERGE PARC CHANGES IN
; MAKE THE ERROR IN SYSOUT BE FILE WON'T OPEN
;<HARTLEY>LISP.MAC.1 13-Jul-77 19:18:22 EDIT BY HARTLEY
;FIX LINELENGTH
;<NEWLISP>LISP.MAC.11 11-Jul-77 20:43:38 EDIT BY HARTLEY
;FIX THE GC STACK EXPANDER SO DOESNT TRAP IN VARIOUS WAYS
;<NEWLISP>LISP.MAC.9 24-Jun-77 18:11:26 EDIT BY HARTLEY
;FIX SYSOUT FOR MULTI-FORK SHADOW LAND
;<LEWIS>LISP.MAC.1 20-Jun-77 15:27:44 EDIT BY LEWIS
; FIX GETEOFPTR
;<NEWLISP>LISP.MAC.7 6-Jun-77 17:18:19 EDIT BY HARTLEY
;FIX STACK BUG IN ECOP
;<LEWIS>LISP.MAC.1 4-Jun-77 02:02:41 EDIT BY LEWIS
; add fast GETFILEPTR
;<NEWLISP>LISP.MAC.5 3-May-77 00:11:50 EDIT BY LEWIS
; fix user data type uuo's
;<NEWLISP>LISP.MAC.4 29-Apr-77 17:07:38 EDIT BY HARTLEY
;CHANGE HASH FNS SO (LIST (HARRAY ...))IS LEGAL VAL FOR SYSHASHARRAY
;<NEWLISP>LISP.MAC.3 6-Apr-77 00:19:44 EDIT BY LEWIS
; fixed printing of deletecontrol msgs to check for eol
;<NEWLISP>LISP.MAC.2 1-Apr-77 16:42:22 EDIT BY LEWIS
; Fix INTFX to clear LSTSWF if it is the same as the frame being flushed
;<NEWLISP>LISP.MAC.1 30-Mar-77 12:02:05 EDIT BY LEWIS
; FIX TCO1 TO RESTORE EOL TO AC1 WHEN PRINTING AN EOL
;<NEWLISP>20LISP.MAC.24 15-Mar-77 21:03:37 EDIT BY HARTLEY
;FIX SYSOUT BECAUSE OF CROCKS IN BOTH TENEX AND TOPS20
;<NEWLISP>20LISP.MAC.23 15-Mar-77 20:49:04 EDIT BY HARTLEY
;FIX PEEKC OF THE INFAMOUS EOL
;<NEWLISP>20LISP.MAC.21 8-Mar-77 20:05:40 EDIT BY HARTLEY
;FIX POSITION
;<NEWLISP>20LISP.MAC.20 7-Mar-77 19:03:08 EDIT BY HARTLEY
;FIX CONTROL-W ECHO TO NOT
;<NEWLISP>20LISP.MAC.18 7-Mar-77 01:51:49 EDIT BY HARTLEY
;MINOR MODS TO SETINC AND ENABLECHAR
;<NEWLISP>20LISP.MAC.13 4-Mar-77 05:51:38 EDIT BY HARTLEY
;<NEWLISP>20LISP.MAC.12 22-Feb-77 19:43:47 EDIT BY HARTLEY
;FIX TO SET U/NP CONTROL U ALSO
;<HARTLEY>20LISP.MAC.25 18-Feb-77 20:32:09 EDIT BY HARTLEY
;FIX BKSYSBUF TO ELIMINATE 37'S
;<HARTLEY>20LISP.MAC.22 18-Feb-77 16:08:51 EDIT BY HARTLEY
;FIXES FOR INTERRUPT AND EDIT CHARACTERS
;<NEWLISP>20LISP.MAC.6 16-Feb-77 23:00:01 EDIT BY LEWIS
; fox problems with illegal go's.
;<NEWLISP>20LISP.MAC.4 16-Feb-77 22:34:35 EDIT BY LEWIS
; increase space for system line buffer and increase max # of open files
;<HARTLEY>20LISP.MAC;19 7-Feb-77 20:54:25 EDIT BY HARTLEY
;<HARTLEY>LISP.MAC.91 6-Feb-77 17:53:17 EDIT BY HARTLEY
;<LEWIS>LISP.MAC.5 9-Jan-77 23:35:47 EDIT BY LEWIS
; Convert to KL20.
;<NEWLISP>LISP.MAC;20 19-Nov-76 03:12:47 EDIT BY HARTLEY
;GIVE SUBSTRING 4TH ARG
;<NEWLISP>LISP.MAC;19 19-Nov-76 00:25:07 EDIT BY HARTLEY
;FIX CROCK IN GETHASH/PUTHASH
;<NEWLISP>LISP.MAC;18 18-Nov-76 22:21:41 EDIT BY HARTLEY
;ADD CONNECTION TO MINHASH
;<LEWIS>LISP.MAC;2 13-Oct-76 01:07:10 EDIT BY LEWIS
; FIX BUG IN FRAMESCAN
;<LEWIS>LISP.MAC;1 18-Sep-76 13:14:29 EDIT BY LEWIS
;<LEWIS>LISP.MAC;1 15-Sep-76 23:39:12 EDIT BY LEWIS
; put in larrys code for getfileptr, setfileptr and geteofptr
;<NEWLISP>LISP.MAC;13 20-Aug-76 17:39:48 EDIT BY LEWIS
; fix evalv, fndbnd was cking EIB instead of BIB
;<LEWIS>LISP.MAC;2 19-Aug-76 04:07:55 EDIT BY LEWIS
; make FPLUS and FQUOTIENT to use rounding instructions.
; redefine FREMAINDER to be like fortran.
;<NEWLISP>LISP.MAC;11 12-Jul-76 21:02:12 EDIT BY LEWIS
; add INTERRUPTABLE and INTERRUPTABLEP
;<NEWLISP>LISP.MAC;8 2-Jul-76 22:06:11 EDIT BY LEWIS
; allow user defined evaluation and printing of valuecells
;<NEWLISP>LISP.MAC;7 30-Jun-76 13:47:49 EDIT BY LEWIS
; CHANGE THE CLRBFN LABEL TO CLRBF9 TO PREVENT CONFLICT WITH
; CLRBFN DEFINED BY THE "U" MACRO.
;<HARTLEY>LISP.MAC;64 29-Jun-76 02:51:32 EDIT BY HARTLEY
;FIX STACK OVERFLOW IN GC TO PUT HOLE MARK IN OLD REGION
;<NEWLISP>LISP.MAC;4 27-Jun-76 14:54:27 EDIT BY LEWIS
; comming out of readmacro.. keep current gchdqf
;<HARTLEY>LISP.MAC;63 16-Jun-76 15:55:34 EDIT BY HARTLEY
;FIX SKIP OVER STE IN CLSTK
;<NEWLISP>LISP.MAC;2 7-Jun-76 15:36:42 EDIT BY LEWIS
;<NEWLISP>LISP.MAC;1 4-Jun-76 14:41:14 EDIT BY LEWIS
; fix potential short frame caused by BBINDQ (old frame in block)
;<LEWIS>LISP.MAC;6 28-May-76 00:02:09 EDIT BY LEWIS
; make cdr printleves work in a "triangular" manner ala lvlprint
;<NEWLISP>LISP.MAC;10 27-May-76 16:45:39 EDIT BY LEWIS
;<LEWIS>LISP.MAC;8 27-May-76 01:05:33 EDIT BY LEWIS
;<LEWIS>LISP.MAC;7 26-May-76 18:37:29 EDIT BY LEWIS
; make control p take input as carn,cdrn.
; add a FILE arg to BACKTRACE
; add CDR printlevels and flag for making printleveles work on files
;<LEWIS>LISP.MAC;1 24-May-76 23:16:21 EDIT BY LEWIS
; Put back in PBIND2/BBINDQ code. it's obsolete, but there are a lot of
; files that still have them in.
;<HARTLEY>LISP.MAC;61 21-May-76 02:08:43 EDIT BY HARTLEY
;FIX POTENTIAL SHORT FRAME CAUSED BY BINDB (FRAME IN BLOCK)
;<NEWLISP>LISP.MAC;2 13-May-76 01:20:21 EDIT BY HARTLEY
;UP BEGTMP AGAIN!
;<HARTLEY>LISP.MAC;58 7-May-76 01:43:46 EDIT BY HARTLEY
;<NEWLISP>LISP.MAC;9 28-Apr-76 15:43:37 EDIT BY LEWIS
;<NEWLISP>LISP.MAC;8 26-Apr-76 15:08:22 EDIT BY LEWIS
; fixed ELT/ELTD for swapped arrays (again)
;<NEWLISP>LISP.MAC;7 22-Apr-76 00:21:35 EDIT BY HARTLEY
;<NEWLISP>LISP.MAC;6 21-Apr-76 16:55:11 EDIT BY LEWIS
; MORE REENTER STUFF
;<NEWLISP>LISP.MAC;4 20-Apr-76 16:51:41 EDIT BY HARTLEY
;REINSTALL SWPFIX IN ECOP - ITS REMOVAL WAS A CROCK
;<NEWLISP>LISP.MAC;3 13-Apr-76 18:53:08 EDIT BY LEWIS
; take REEENTER out of entry vector.
;<META>LISP.MAC;159 4-Apr-76 15:45:18 EDIT BY LEWIS
; clear inactive bit from num of args in pplook.
;<META>LISP.MAC;158 2-Apr-76 22:29:37 EDIT BY LEWIS
; move cell for eveval blip so gc knows about it.
;<META>LISP.MAC;157 1-Apr-76 15:27:20 EDIT BY LEWIS
; in RETURN check that the frame being returned from has the
;function def of PROG, not just the name.
;<META>LISP.MAC;156 1-Apr-76 01:07:12 EDIT BY HARTLEY
;FIX AN ENVEVAL BUG AND CHANGE NAME OF DUMMYFRAMES TO *ENV*
;<META>LISP.MAC;155 31-Mar-76 22:05:58 EDIT BY LEWIS
; change time accounting back to looking at whole job
;<META>LISP.MAC;154 31-Mar-76 20:52:30 EDIT BY LEWIS
; verify that RETURN returns from a PROG frame. (not *prog*lam)
;<META>LISP.MAC;153 25-Mar-76 21:25:08 EDIT BY HARTLEY
;<META>LISP.MAC;151 19-Mar-76 01:08:29 EDIT BY HARTLEY
;CHANGED STE AND STN MACROS
;<META>LISP.MAC;150 18-Mar-76 23:35:01 EDIT BY HARTLEY
;<META>LISP.MAC;149 18-Mar-76 22:51:30 EDIT BY LEWIS
; change backtrace so bit 4 prints subr args, and bit 40 prints junk
;<META>LISP.MAC;146 15-MAR-76 19:06:27 EDIT BY HARTLEY
;<META>LISP.MAC;145 12-MAR-76 03:14:51 EDIT BY HARTLEY
;MAKE STACK ALLOCATOR GIVE FRAME BIGGER SLOT
;<META>LISP.MAC;144 2-MAR-76 16:25:30 EDIT BY LEWIS
; insert JRST .-1 after error HALTF's, and save trap acs
;<META>LISP.MAC;141 27-FEB-76 03:24:19 EDIT BY LEWIS
; fix fast enterf's to work on swapped fns
;<META>LISP.MAC;140 26-FEB-76 21:38:23 EDIT BY LEWIS
; fix ENTER1 'cause of the way SOJLE 1,FOO(1) works
;<META>LISP.MAC;139 26-FEB-76 04:42:27 EDIT BY LEWIS
; fixed FMEMB to overcome *argval* problems with 1st arg
;<META>LISP.MAC;138 26-FEB-76 04:30:59 EDIT BY LEWIS
; increase the PP stk size
;<META>LISP.MAC;137 26-FEB-76 03:22:19 EDIT BY LEWIS
; add new fast ENTERF's
;<META>LISP.MAC;135 25-FEB-76 02:06:56 EDIT BY HARTLEY
;<META>LISP.MAC;134 24-FEB-76 02:32:43 EDIT BY LEWIS
; fix backtrace so btarg saves/restores ac6
;<META>LISP.MAC;133 23-FEB-76 16:41:00 EDIT BY LEWIS
; fix blkapply* for swapped code.
;<META>LISP.MAC;130 23-FEB-76 01:33:12 EDIT BY HARTLEY
;PUT IN ENVEVAL AND COPYSTK FIXES - FIX GC STACK BUG
;<META>LISP.MAC;126 17-FEB-76 02:29:36 EDIT BY HARTLEY
;<META>LISP.MAC;121 16-FEB-76 00:34:24 EDIT BY HARTLEY
;FIX NLGO BUG
;<META>LISP.MAC;117 12-FEB-76 23:48:28 EDIT BY HARTLEY
;SOME CHANGES TO SWAPPED BLOCK SUBFRAMES F0R SPEED
;<META>LISP.MAC;115 5-FEB-76 23:36:28 EDIT BY HARTLEY
;<HARTLEY>LISP.MAC;47 5-FEB-76 02:00:25 EDIT BY HARTLEY
;FIX SOME CONTROL-B PROBLEMS AND UNWIND ON STACK OVERFLOW
;<META>LISP.MAC;111 3-FEB-76 22:23:45 EDIT BY LEWIS
; more fast swpret stuff
;<META>LISP.MAC;109 2-FEB-76 21:55:15 EDIT BY LEWIS
; fix (position file n) to return previous position
;<META>LISP.MAC;108 2-FEB-76 20:28:17 EDIT BY LEWIS
; make CFRAM to have more smarts about swapped frames
;<HARTLEY>L3.MAC;2 31-JAN-76 02:35:01 EDIT BY HARTLEY
;DO THE COPYSTK FIXES
;<HARTLEY>LISP.MAC;45 31-JAN-76 01:39:09 EDIT BY HARTLEY
;FIX SOME STACK PROBLEMS
;<META>LISP.MAC;101 28-JAN-76 20:53:25 EDIT BY LEWIS
; add corevals for SET and KNOB
;<META>LISP.MAC;100 26-JAN-76 13:43:17 EDIT BY LEWIS
;<META>LISP.MAC;99 23-JAN-76 20:15:27 EDIT BY LEWIS
; speed up EVALV and friends
;<META>LISP.MAC;96 17-JAN-76 16:13:08 EDIT BY LEWIS
; remove ff references
; reorder some corevals
; take out stuff to do with freevariable page traps
; fix evaluations for when an atoms BOUND to NOBIND
;<META>LISP.MAC;90 13-JAN-76 22:00:41 EDIT BY LEWIS
; fix fndbnd to get proper # of args
;<META>LISP.MAC;89 13-JAN-76 11:44:43 EDIT BY LEWIS
; more blkock compile fixes
;<META>LISP.MAC;88 9-JAN-76 21:11:59 EDIT BY LEWIS
; another fix to bindq (push old pp on before old vp)
;<META>LISP.MAC;86 8-JAN-76 01:05:14 EDIT BY LEWIS
; change sysout/makesys to allow for value cells
;<META>LISP.MAC;85 8-JAN-76 00:27:06 EDIT BY LEWIS
; fix a problem with lambda n's
;<META>LISP.MAC;84 7-JAN-76 23:50:03 EDIT BY LEWIS
; MORE SHALLOW BLOCK COMPILER
;<META>LISP.MAC;78 30-DEC-75 10:06:06 EDIT BY LEWIS
; MAKE EVALA WORK
;<META>LISP.MAC;70 22-DEC-75 06:27:15 EDIT BY LEWIS
; SHALLOW CHANGES FOR BLOCK COMPILED CODE
;<META>LISP.MAC;69 20-DEC-75 01:29:28 EDIT BY LEWIS
; SHALLOW CHANGES FOR COMPILED CODE
;<META>LISP.MAC;63 11-DEC-75 22:29:46 EDIT BY LEWIS
; ADD THE USERFNS VCELLP, VCTOAT AND AT2VC
;<META>LISP.MAC;62 29-OCT-75 23:01:01 EDIT BY LEWIS
; make peekc take a read table
;<META>LISP.MAC;61 27-OCT-75 13:49:12 EDIT BY LEWIS
; FIX GETTOPVAL AND SETTOPVAL FOR SHALLOW
;<META>LISP.MAC;57 21-OCT-75 02:21:39 EDIT BY LEWIS
;<META>LISP.MAC;35 19-OCT-75 23:14:57 EDIT BY LEWIS
; TAKE OUT NONAC AND TO MORE SHALLOW BINDING.
;<META>LISP.MAC;31 12-OCT-75 02:52:21 EDIT BY LEWIS
; FIXED RATEST TO WORK OFF OF RATOM INSTEAD OF MKATOM
;<META>LISP.MAC;30 9-OCT-75 23:33:21 EDIT BY LEWIS
;<HARTLEY>NLIST.MAC;5 27-SEP-75 02:42:32 EDIT BY HARTLEY
;<HARTLEY>LISP.MAC;32 24-SEP-75 18:47:55 EDIT BY HARTLEY
;ADD VALUE CELLS
;<HARTLEY>LISP.MAC;22 28-AUG-75 18:26:17 EDIT BY HARTLEY
; FOR IMMEDIATE TYPE NUMS, NEW CONS
;<HARTLEY>LISP.MAC;16 27-AUG-75 03:06:44 EDIT BY HARTLEY
;<HARTLEY>LISP.MAC;11 26-AUG-75 01:29:17 EDIT BY HARTLEY
;CHANGED SOME ERROR NUMBERS
;<NEWLISP>LISP.MAC;26 18-AUG-75 21:22:54 EDIT BY LEWIS
; added RETTO and deleted the defunct STKCALL.
;<HARTLEY>LISP.MAC;9 5-AUG-75 02:55:23 EDIT BY HARTLEY
;ADDED MORE COREVALS
;<LEWIS>LISP.MAC;2 30-JUL-75 20:46:00 EDIT BY LEWIS
; MAKE CLOSEF RETURN NIL IF YOU TRY TO CLOSE T OR THE DRIBBLE FILE
;<HARTLEY>LISP.MAC;7 29-JUL-75 23:39:35 EDIT BY HARTLEY
; ADDED SOME NEW COREVALS
;<HARTLEY>LISP.MAC;5 24-JUL-75 18:02:08 EDIT BY HARTLEY
; MADE FRPLACA, FRPLACD, GETTOPVAL, SETTOPVAL, SETPROPLIST, SUBRS
;<HARTLEY>LISP.MAC;4 24-JUL-75 02:46:20 EDIT BY HARTLEY
; PUT IN NEW OPCODE (ALNCAL) AND NEW COREVALS FOR NEW COMPILER
;<NEWLISP>LISP.MAC;20 23-JUL-75 16:47:19 EDIT BY LEWIS
; change READP to look at the terminal table for the EOL char.
;<LEWIS>LISP.MAC;7 30-JUN-75 17:24:42 EDIT BY LEWIS
; ALSO ADDED A FIX FOR ALICE
; ADDED INSTANT INTERRUPTS THAT JUST SET A VARIABLE.
;<LEWIS>LISP.MAC;2 27-JUN-75 14:35:46 EDIT BY LEWIS
; FIXED A PROBLEM WITH ENABLE/DISABLE INTERRUPT CHARS.
;<LEWIS>LISP.MAC;2 25-JUN-75 12:02:09 EDIT BY LEWIS
; FIX SPACES TO ALWAYS PRINT THE SPACES.
;<LEWIS>LISP.MAC;6 22-JUN-75 20:07:32 EDIT BY LEWIS
; MAKE PRIN3 AND PRIN4 LIKE PRIN1 AND PRIN2 BUT NOT INCREMENT POSITION
;<LEWIS>LISP.MAC;13 19-JUN-75 12:38:35 EDIT BY LEWIS
; ADDED IEQP AND FIXED TTY POSITION WHEN ECHO IS OFF
;<LEWIS>LISP.MAC;9 18-JUN-75 15:05:37 EDIT BY LEWIS
; PUT IN DRIBBLE AND PRIN3
;<DLISP>LISP.MAC;84 18-JUN-75 02:51:36 EDIT BY HARTLEY
;<DLISP>LISP.MAC;83 17-JUN-75 02:09:59 EDIT BY HARTLEY
;<DLISP>LISP.MAC;81 16-JUN-75 23:45:02 EDIT BY HARTLEY
;<DLISP>LISP.MAC;78 14-JUN-75 03:10:31 EDIT BY HARTLEY
;<DLISP>LISP.MAC;77 12-JUN-75 11:05:05 EDIT BY LEWIS
; fix bug with accessing the read blip
;<DLISP>LISP.MAC;75 12-JUN-75 03:43:14 EDIT BY HARTLEY
;<DLISP>LISP.MAC;72 12-JUN-75 02:31:48 EDIT BY HARTLEY
;<DLISP>LISP.MAC;71 10-JUN-75 17:16:49 EDIT BY HARTLEY
;<DLISP>LISP.MAC;70 6-JUN-75 03:25:02 EDIT BY HARTLEY
;FIX FLUSH OF BASIC FRAME
;<DLISP>LISP.MAC;68 4-JUN-75 04:14:15 EDIT BY HARTLEY
; BEGIN TO FIX STACK OVERFLOW TO PERMIT BREAKS
;<DLISP>LISP.MAC;67 28-MAY-75 23:32:04 EDIT BY HARTLEY
;FIX BUG IN BLKAPPLY* WHEN FN NOT IN BLOCK
;<NEWLISP>LISP.MAC;8 20-MAY-75 19:59:26 EDIT BY LEWIS
; FIX BAD ATOM DEF OF "READMACROS"
;<NEWLISP>LISP.MAC;7 16-MAY-75 00:50:24 EDIT BY LEWIS
; FIX BUG IN PRINTING USER DATA TYPES
;<DLISP>LISP.MAC;62 15-MAY-75 18:09:42 EDIT BY HARTLEY
;<DLISP>LISP.MAC;61 14-MAY-75 22:41:48 EDIT BY LEWIS
; ADD PRINTING OF USER DATA TYPES.
;<DLISP>LISP.MAC;56 14-MAY-75 00:17:42 EDIT BY HARTLEY
;<DLISP>LISP.MAC;54 8-MAY-75 01:03:16 EDIT BY HARTLEY
;<DLISP>LISP.MAC;53 7-MAY-75 01:54:20 EDIT BY HARTLEY
; FIX BUG IN APPLY/EVAL OF FUNARG
;<DLISP>LISP.MAC;52 6-MAY-75 00:14:26 EDIT BY HARTLEY
; FIX BAD CHCON1 BUG WHEREIN STACK GOT FOULED
;<DLISP>LISP.MAC;51 2-MAY-75 21:14:35 EDIT BY LEWIS
; fix bug in NALLOC at GCUSER where it returned to wrong place
;<DLISP>LISP.MAC;45 1-MAY-75 03:28:46 EDIT BY HARTLEY
;<DLISP>LISP.MAC;44 30-APR-75 02:37:05 EDIT BY HARTLEY
; FIX BUG IN ENVEVAL
;<DLISP>LISP.MAC;43 30-APR-75 00:43:25 EDIT BY HARTLEY
; FIX ALL ASSUMPTIONS THAT LEFT HALF OF SUBR BINDING = 0 - IT AINT
;<DLISP>LISP.MAC;42 29-APR-75 13:27:44 EDIT BY LEWIS
; fixed typo in the definition of the atom USERCONS
;<DLISP>LISP.MAC;39 26-APR-75 03:26:25 EDIT BY HARTLEY
; ADD ENVAPPLY
;<DLISP>LISP.MAC;37 26-APR-75 01:29:13 EDIT BY HARTLEY
; MAKE ARGTYPE WORK FOR FUNARGS, FIX COMPILED APPLY* OF FUNARG
;<DLISP>LISP.MAC;36 23-APR-75 03:10:38 EDIT BY HARTLEY
; FIX STKSCAN
;<HARTLEY>LISP.MAC;1 21-APR-75 17:47:17 EDIT BY HARTLEY
; FIX SETN BUG
;<DLISP>LISP.MAC;33 19-APR-75 01:00:02 EDIT BY HARTLEY
; FIX OPNJFN() TO BE ERROR, APPLY* FUNARG
;<DLISP>LISP.MAC;32 18-APR-75 20:40:32 EDIT BY LEWIS
; MAKE PEEKC AND PRIN1 HAVE 2 ARGS
;<DLISP>LISP.MAC;28 10-APR-75 02:51:54 EDIT BY HARTLEY
; FIX STACK OVERFLOW AND CATCH RETFROM TOP
;<DLISP>LISP.MAC;27 9-APR-75 01:45:06 EDIT BY HARTLEY
;<DLISP>LISP.MAC;26 5-APR-75 15:46:47 EDIT BY HARTLEY
;<DLISP>LISP.MAC;25 26-MAR-75 00:43:26 EDIT BY LEWIS
; turn on bit 0 of aicc so 1st user interrupt char will work
;<DLISP>LISP.MAC;22 23-MAR-75 23:35:52 EDIT BY HARTLEY
;<DLISP>LISP.MAC;21 15-MAR-75 17:26:11 EDIT BY LEWIS
; RSTRING IS SUPPOSE TO TAKE 2 ARGS, NOT 1 (SECOND IS A READTABLE)
;<DLISP>LISP.MAC;20 10-MAR-75 03:12:53 EDIT BY HARTLEY
;<DLISP>LISP.MAC;19 7-MAR-75 04:06:30 EDIT BY HARTLEY
;<DLISP>LISP.MAC;17 12-FEB-75 12:24:06 EDIT BY HARTLEY
;<DLISP>LISP.MAC;13 1-FEB-75 01:58:38 EDIT BY HARTLEY
;ADD SETBLIPVAL AND IMPROVE BLIPEVAL
;<DLISP>LISP.MAC;12 31-JAN-75 20:10:24 EDIT BY HARTLEY
; FANCY BACKTRACE WITH *FN* ETC.
;<DLISP>LISP.MAC;11 11-DEC-74 16:01:37 EDIT BY LEWIS
; FIX A READMACRO PROBLEM WITH "]", EG, INPUTING 'A]
;<DLISP>LISP.MAC;10 9-DEC-74 15:29:19 EDIT BY LEWIS
; MAKE ELT TAKE SWAPPED ARRAYS
;<DLISP>LISP.MAC;9 5-DEC-74 01:05:22 EDIT BY HARTLEY
;ADD STKNTHNAME
;<DLISP>LISP.MAC;6 4-DEC-74 03:29:23 EDIT BY HARTLEY
;<DLISP>LISP.MAC;5 3-DEC-74 03:07:37 EDIT BY HARTLEY
;ADD FUNARG
;<DLISP>LISP.MAC;4 3-DEC-74 02:40:10 EDIT BY HARTLEY
; FIX EVALA, MAKE STKARG,SETSTKARG,ETC. TAKE NAME AS WELL
;AS NUMBER, SPEED UP REBIND
;<DLISP>LISP.MAC;3 30-NOV-74 15:01:45 EDIT BY LEWIS
; FIX INREADMACROP, SETREADMACROP. AND CHANGE ↑A MESSAGES TO NEW FORM.
;<NEWLISP>LISP.MAC;5 25-NOV-74 12:41:21 EDIT BY LEWIS
; MAKE FILE NAMES ALWAYS HAVE DIRECTORY.
;<NEWLISP>LISP.MAC;3 24-NOV-74 02:14:17 EDIT BY HARTLEY
; FIX WTRP FOR KI-10
;<NEWLISP>LISP.MAC;2 23-NOV-74 03:42:45 EDIT BY HARTLEY
;FIX CONTROL-H
;<DLISP>NNLISP.MAC;64 17-NOV-74 05:21:53 EDIT BY LEWIS
; FIX AN ERRORSTRING TYPO
;<DLISP>NNLISP.MAC;61 16-NOV-74 23:39:49 EDIT BY HARTLEY
;<DLISP>NNLISP.MAC;58 16-NOV-74 19:10:57 EDIT BY HARTLEY
;<DLISP>NNLISP.MAC;56 16-NOV-74 16:14:23 EDIT BY HARTLEY
;<DLISP>NNLISP.MAC;55 16-NOV-74 05:52:35 EDIT BY HARTLEY
; ADD COPYSTK
;<DLISP>NNLISP.MAC;54 16-NOV-74 03:40:09 EDIT BY LEWIS
; FIX COND AGAIN, ADD ERRORSTRING, FIX MAKESYS/RAISE STUFF
;<DLISP>NNLISP.MAC;52 16-NOV-74 00:31:47 EDIT BY LEWIS
; REINSTALL INREADMACROP SETREADMACROFLG
;<DLISP>NNLISP.MAC;49 15-NOV-74 23:49:08 EDIT BY HARTLEY
;<DLISP>NNLISP.MAC;48 15-NOV-74 23:03:55 EDIT BY HARTLEY
;<DLISP>NNLISP.MAC;47 11-NOV-74 02:36:37 EDIT BY HARTLEY
;<DLISP>NNLISP.MAC;45 9-NOV-74 01:32:35 EDIT BY HARTLEY
;FIX INTERACTION OF NON-LOCAL GO AND SWAPPER
;<DLISP>NNLISP.MAC;44 8-NOV-74 19:45:44 EDIT BY LEWIS
; USE INTERNAL CALL TO APPLY* WHEN CALLING READMACRO FUNCTIONS.
;<DLISP>NNLISP.MAC;43 6-NOV-74 02:00:30 EDIT BY LEWIS
;<DLISP>NNLISP.MAC;42 5-NOV-74 20:21:32 EDIT BY LEWIS
; FIXED PPOBLEM WITH LREAD BEING SET WHEN ENTERING MKATM
;<DLISP>NNLISP.MAC;41 5-NOV-74 15:03:09 EDIT BY LEWIS
; CHANGE INFIX MACROS TO GET A NIL LIST IF AT THE TOPLEVEL
;<DLISP>NNLISP.MAC;39 5-NOV-74 01:41:45 EDIT BY LEWIS
; FIX READMACROS TO SAVE AND RESTORE FRX AND RDAX
;<DLISP>NNLISP.MAC;38 4-NOV-74 13:30:24 EDIT BY LEWIS
; ADD "FIRST", "ALONE", AND "IMMEDIATE" TYPE READMACROS
; MAKE INFIX MACROS WORK WHEN READ AT TOPLEVEL
;<DLISP>NNLISP.MAC;37 30-OCT-74 17:40:43 EDIT BY LEWIS
; RESTORE BACKUP CHAR WHEN CHANGING READING OF STRINGS.
;<DLISP>NNLISP.MAC;35 29-OCT-74 20:13:43 EDIT BY HARTLEY
; MERGE CHANGES FROM OCT 15 TO PRESENT
;<DLISP>LISP.MAC;13 27-OCT-74 03:26:02 EDIT BY HARTLEY
;<DLISP>LISP.MAC;10 24-OCT-74 21:45:09 EDIT BY HARTLEY
;<DLISP>LISP.MAC;5 22-OCT-74 16:55:54 EDIT BY HARTLEY
;<DLISP>LISP.MAC;4 19-OCT-74 03:42:11 EDIT BY HARTLEY
;<DLISP>LISP.MAC;3 18-OCT-74 20:16:10 EDIT BY HARTLEY
;<DLISP>LISP.MAC;2 18-OCT-74 04:59:18 EDIT BY HARTLEY
;<DLISP>NNLISP.MAC;21 15-OCT-74 00:51:21 EDIT BY HARTLEY
; FIX PPLOOK FOR SPECVARS IN BLOCKS
;<DLISP>NNLISP.MAC;20 11-OCT-74 23:26:37 EDIT BY LEWIS
; FIX INTERACTIONS BETWEEN CONTROL/RAISE AND READMACROS
;<DLISP>NNLISP.MAC;19 11-OCT-74 14:28:31 EDIT BY LEWIS
; fix inter.raise problm with control=T, & control(T) always ret.NIL.
;<DLISP>NNLISP.MAC;18 10-OCT-74 12:14:51 EDIT BY LEWIS
;<LEWIS>NNLISP.MAC;1 10-OCT-74 12:06:52 EDIT BY LEWIS
; MAKE ↑V ALSO WORK WITH LOWER CASE LETTERS
; TAKE OUT 0/1 FROM CONTROL AND MAKE SYSOUT CLEAR, NOT CLOSE FILE TABLE
;FIX BKLINBUF CHAR COUNT BUG
; PUT RAISE ON TERM.TBL, MAKE MODE T BE 0, DEFINE T AS "INTERNAL RAISE"
;<DLISP>NNLISP.MAC;16 8-OCT-74 14:35:55 EDIT BY LEWIS
; FIX WAKEUP PROBLEM IN PEEKC
;<DLISP>NNLISP.MAC;15 7-OCT-74 17:56:02 EDIT BY LEWIS
;<DLISP>NNLISP.MAC;13 7-OCT-74 17:02:58 EDIT BY HARTLEY
;<DLISP>NNLISP.MAC;12 6-OCT-74 14:41:27 EDIT BY LEWIS
; MAKE CONTROL TAKE TERM.TABLE AND ADD ECHOMODE
;<DLISP>NNLISP.MAC;11 6-OCT-74 11:38:45 EDIT BY LEWIS
; added extra messages to ↑A and added 2nd arg flag to readp
;<DLISP>NNLISP.MAC;10 4-OCT-74 02:54:04 EDIT BY LEWIS
; SEPERATE EDIT AND CTL.CH.ECHO FROM READTABLES INTO TERMINAL TABLES
;<DLISP>NNLISP.MAC;9 24-SEP-74 20:16:18 EDIT BY LEWIS
;<DLISP>NNLISP.MAC;8 23-SEP-74 20:28:05 EDIT BY LEWIS
; MAKE SETBRK GIVE ERROR IF 1ST ARG NOT LIST
;<DLISP>NNLISP.MAC;6 23-SEP-74 19:27:55 EDIT BY LEWIS
; FIX BAD FLTPT. OUTPUT FORMAT BUG.
;<DLISP>NNLISP.MAC;5 19-SEP-74 21:29:13 EDIT BY LEWIS
; FIX NCHARS, CHCON, UNPACK, NTHCHAR (AND IPRE2) TO TAKE A READTABLE
;<DLISP>NNLISP.MAC;4 19-SEP-74 09:49:45 EDIT BY LEWIS
; FIX INFIX MACROS
;<DLISP>NNLISP.MAC;3 16-SEP-74 07:16:53 EDIT BY LEWIS
; READTABLE FNS USE ORIG INSTEAD OF RESET TO REF. PRISTINE TABLE.
;<DLISP>NNLISP.MAC;2 16-SEP-74 05:27:35 EDIT BY LEWIS
; ADD RESETREADTABLE AND COPYREADTABLE, CHANGE SOME OTHER RDTBL FNS
;<LEWIS>NNLISP.MAC;3 14-SEP-74 05:48:44 EDIT BY LEWIS
; INSTALL READTABLE ARGS IN I/O
;<HARTLEY>NNLISP.MAC;29 3-SEP-74 03:46:01 EDIT BY HARTLEY
;<HARTLEY>NNLISP.MAC;27 1-SEP-74 04:21:41 EDIT BY HARTLEY
;<HARTLEY>NNLISP.MAC;25 30-AUG-74 17:26:42 EDIT BY HARTLEY
; FIX INTFX, SUBRP, AND BLKENT
;<HARTLEY>NNLISP.MAC;21 27-AUG-74 22:23:37 EDIT BY HARTLEY
;<HARTLEY>NNLISP.MAC;16 25-AUG-74 18:09:50 EDIT BY HARTLEY
;<HARTLEY>NNLISP.MAC;13 24-AUG-74 20:33:28 EDIT BY HARTLEY
;<HARTLEY>NNLISP.MAC;9 21-AUG-74 01:36:02 EDIT BY HARTLEY
;<HARTLEY>NNLISP.MAC;8 20-AUG-74 18:39:37 EDIT BY HARTLEY
;<HARTLEY>NNLISP.MAC;7 20-AUG-74 03:16:26 EDIT BY HARTLEY
;<HARTLEY>NNLISP.MAC;5 17-AUG-74 04:03:30 EDIT BY HARTLEY
;<FLIP>LISP.MAC;20 4-AUG-74 15:30:37 EDIT BY LEWIS
; CHANGED FORMAT OF SWAPPER ERROR MESSAGES
;<FLIP>LISP.MAC;18 24-JUL-74 18:03:28 EDIT BY LEWIS
; PUT IN SWAPPER
;<FLIP>LISP.MAC;7 16-JUL-74 07:19:06 EDIT BY LEWIS
; ADDED ALICE'S LATEST FIXES
;<FLIP>LISP.MAC;5 13-JUL-74 23:56:30 EDIT BY LEWIS
; MORE ENABLECHAR AND DISABLECHAR
;<FLIP>LISP.MAC;4 9-JUL-74 19:57:58 EDIT BY LEWIS
; ADDED COREVALS FOR FAST FN-OPENR/CLOSER FNS
;<FLIP>LISP.MAC;3 9-JUL-74 01:18:38 EDIT BY LEWIS
; ADDED FN-OPENR/CLOSER FNS
;<FLIP>LISP.MAC;2 3-JUL-74 22:03:51 EDIT BY LEWIS
;<LEWIS>LISP.MAC;51 27-JUN-74 05:39:27 EDIT BY LEWIS
;<LEWIS>LISP.MAC;49 25-JUN-74 19:43:18 EDIT BY LEWIS
; MERGED WITH SPAG.
;<LEWIS>LISP.MAC;1 13-JUN-74 06:43:51 EDIT BY LEWIS
; FIXED BUG IN RSTRING DUE TO READTABLES
;<LEWIS>LISP.MAC;1 10-JUN-74 10:53:18 EDIT BY LEWIS
; FIXED BUG IN UNBUFFERED READ
;<LEWIS>LISP.MAC;1 9-JUN-74 00:35:39 EDIT BY LEWIS
; FIXED READP FOR READING STRINGS
;<LEWIS>LISP.MAC;4 8-JUN-74 05:27:34 EDIT BY LEWIS
; FIXED BACKTRACE FOR WARREN
;<LEWIS>LISP.MAC;1 7-JUN-74 20:51:15 EDIT BY LEWIS
; FIXED STKNTH FOR WARREN
;<LEWIS>LISP.MAC;2 6-JUN-74 04:15:50 EDIT BY LEWIS
; FIXED BUG IN GNC AND ADDED READING FROM STRINGS
;<LEWIS>LISP.MAC;8 5-JUN-74 04:23:23 EDIT BY LEWIS
; FIXED SQBRK AND ADDED USER INTERRUPT CHARACTERS
;<NEWLISP>LISP.MAC;3 3-JUN-74 19:53:20 EDIT BY LEWIS
; FIX ESCAPE ALWAYS RETURNING NIL PROBLEM
;<GOODWIN>LISP.MAC;20 24-MAY-74 07:57:04 EDIT BY GOODWIN
;Fixed FTRP1 to relocate right to find freevar vector.
;<GOODWIN>FIE.;100018 3-MAY-74 04:03:36 EDIT BY GOODWIN
; - INSTALLING SWAPPER, FLUSH E+S DISPLAY SWITCHED CODE. JWG
;<FLIP>LISP.MAC;82 23-APR-74 15:17:47 EDIT BY LEWIS
;<FLIP>LISP.MAC;81 7-APR-74 00:45:13 EDIT BY LEWIS
;INSERTED ALICE'S CHANGES FOR PRXFLG
;<FLIP>LISP.MAC;80 31-MAR-74 14:25:15 EDIT BY LEWIS
;<FLIP>LISP.MAC;2 18-MAR-74 21:04:05 EDIT BY LEWIS
;<FLIP>LISP.MAC;1 19-FEB-74 00:25:30 EDIT BY LEWIS
;<FLIP>LISP.MAC;5 18-FEB-74 01:53:47 EDIT BY LEWIS
;<FLIP>LISP.MAC;3 17-FEB-74 19:46:52 EDIT BY LEWIS
;<FLIP>LISP.MAC;3 17-FEB-74 03:40:14 EDIT BY LEWIS
;<FLIP>LISP.MAC;3 11-FEB-74 18:02:52 EDIT BY LEWIS
;<HARTLEY>LISP.MAC;24 6-FEB-74 19:19:16 EDIT BY HARTLEY
;<HARTLEY>LISP.MAC;21 6-FEB-74 02:16:23 EDIT BY HARTLEY
;<FLIP>LISP.MAC;3 5-FEB-74 08:51:52 EDIT BY LEWIS
;<LEWIS>LISP.MAC;1 5-FEB-74 07:08:47 EDIT BY LEWIS
;<FLIP>LISP.MAC;2 3-FEB-74 09:40:53 EDIT BY LEWIS
;<HARTLEY>LISP.MAC;16 1-FEB-74 21:02:51 EDIT BY HARTLEY
;<HARTLEY>LISP.MAC;8 31-JAN-74 03:16:13 EDIT BY HARTLEY
;<FLIP>LISP.MAC;8 30-JAN-74 02:07:36 EDIT BY LEWIS
TITLE LISP
;20 AUG 74, 2006:
;SYSTEM SWITCH, 0 FOR TENEX, 1 FOR 10/50
IFNDEF TEN50,<TEN50==0>
IFN TEN50,<
EXTERN CIO,FINIT,INFIL,OUTFIL,RFNM,CLOSEF
EXTERN JOBSYM,JOBSA,JOBREL,JOBDDT,JOBREN,JOBOPC,JOBFF
>
IF1,<PURGE CDR>
SYSDAT=777 ;DATE OF CREATION - FOR SYSIN CHECK
SEARCH STENEX
;PARAMETERS
NPM==1000 ;MAX NUMBER OF PAGES IN SYSTEM
NPS==1000 ;PAGE SIZE
LPS==11 ;LOG OF PAGE SIZE
MPS==NPS-1 ;PAGE MASK
;INITIAL ALLOCATIONS (NUMBER OF PAGES)
NLW==4 ;LIST WORDS
NAT==6 ;ATOMS
NHT==20 ;ATOM HAST TABLE - MUST BE POWER OF 2
MAXNHT==100 ;MAX # PAGES HASH TABLE CAN GROW TO
NFN==1 ;FLOATING NUMBERS
NNM==1 ;INTEGER NUMBERS
NPN==4 ;PNAME STRINGS
NST==1 ;REGULAR STRINGS
NSP==1 ;STRING POINTERS
NAR==3 ;ARRAYS
NHDL==1 ;HANDLES
NSTKP==1 ;STACK POINTERS
NVC==1 ;VALUE CELLS
;INITIAL SIZES
IFNDEF NCP,<NCP==12000> ;CONTROL STACK
IFNDEF NPP,<NPP==12000> ;PARAMETER STACK
NIP==24 ;INTERRUPT LEVEL STACK
NREDCP==676 ;EMERGENCY STACK - IS SUBTRACTED FROM NCP
NREDPP==676 ;EMERGENCY STACK
NFILES==40
NFRKS==4 ;NUMBER OF FORKS FOR SHADOW SPACE
MFRKS==3 ;MASK FOR ABOVE
;AC ASSIGNMENTS
CP=17 ;CONTROL STACK
PP=16 ;PARAMETER STACK
BR=15 ;SWAPPING BASE REG.
VP=14 ;PTR TO ARGS OF RUNNING FN(ONE LESS)
IFDEF MAXC,<
CBS=13 ;BYTE LISP AC
>
TP=12 ;FOR UUO DECODE
TF=11 ;TEMP FLAGS
FX=10 ;FILE INDEX
F=0 ;FLAGS
;MAGIC MARKERS ON STACKS
NMBLIP==21 ;ON CP - NMBLIP,,# NUMS FOLLOWING
EVBLIP==100 ;ON PP - EVBLIP,,FORM FOR EVAL
APBLIP==10 ;ON PP - APBLIP,,ARGLIST FOR APPLY
PRBLIP==40 ;ON PP, PRBLIP,,LIST OF FORMS FOR PROGN
AVBLIP==200 ;ON PP AVBLIP,,ARG VALUE FOR PARTIAL EVAL
FNBLIP==50 ;ON PP FNBLIP(+TYP),,FN NAME FOR PARTIAL EVAL
STKHOL==707 ;ON PP OR CP - STKHOL,,# SLOTS AVAIL
STKEND==717 ;ON PP OR CP - STKEND,,NEXT STK BLOCK OR 0
;MISC
EOL=37 ;END OF LINE CHARACTER
ESC=45 ;% - ESCAPE CHAR, I.E. ONE SHOT QUOTE
NCHRS=1000 ;SIZE OF CHARACTER PSEUDO-SPACE
ACHAR==400 ;ADDRESS OF FIRST CHAR
MSN==6000 ;SIZE OF SMALL NUMBER PSEUDO-SPACE
ASZ=MSN/2+NCHRS ;SMALL NUMBER ZERO
MINWPP==20 ;CONS - MIN FREE WORDS FOR PAGE TO RECEIVE NEW LIST
NATMC==176 ;MAX NUMBER OR CHARS IN ATOM
;FLAGS - RIGHT HALF ARE TEMPORARY
NEGFLG==1 ;ATOM CONSTRUCTER - MINUS SIGN SEEN
LETFLG==2 ; - LETTER SEEN
QFLG==4 ; - Q WAS LAST CHAR
DIGFLG==10 ; - DIGIT SEEN
FLTFLG==20 ; - FLOATING INDICATION
RQTFLG==40 ;DOUBLEQUOTED ATOM
LREAD==100 ;RATOM - LISP READ
RATFLG==200 ;- IN RATOM OR RSTRING
CHFLG==400 ; - CHARACTER PACKED
RMFLG==1000 ;READ BLIP ON STACK
ESCFLG==2000 ;ESCAPE FLAG - LINE BUFFER
GCHDQF==4000 ;WITHIN DOUBLE-QUOTE, LINE BUFFER
RDMFLG==10000 ; - IN A READMACRO
ERQFLG==20000 ;KEYBOARD ERROR REQUEST PENDING
PMCFLG==40000 ;PRINT MARGIN CHECK FLAG
INTFLG==100000 ;KEYBOARD INTERRUPT REQUEST
SEPFLG==200000 ;SEPARATOR PRECEEDED ATOM
GCFLG==400000 ;DOING GC
; - LEFT HALF ARE PERMANENT
PNEGF==1 ;PRINT NEG NUMBER WITH SIGN
LBFFLG==2 ;NO LINEBUFFERING
RASFLG==4 ;INTERNAL INPUT RAISE FLAG
GCF==10 ;TEMP FLAG FOR GC
GCMF==20 ;GC MOVE FLAG-ANY PAGES MOVING
GCCF==40 ;GC COMPACT FLAG-ANY TYPE COMPACTING
GCPF==100 ;GC CHANGE POINTER FLAG-GEN TYPE COMPACTING
;...OR PAGES SHUFFLING
STKFLG==200 ;STACK HAS SKIP BLIP
CNSFLG==400 ;FRECNT=FREBRK
NEGPLF==1000 ;NEGATIVE PRINTLEVEL FLAG
PRPFLG==2000 ;JUST PRINTED RIGHT PAREN
NCRFLG==4000 ;NO EOL ON CLOSING PAREN IN READ
BKFLG==10000 ;PUTTING STRING IN LINE BUFFER
EVLFLG==40000 ;...BUT PERMIT BELOW FIRST LEVEL
HDLFLG==100000 ;FOR GC - HANDLE CHASE IN PROGRESS
PDQFLG==200000 ;PRINT ESCAPES IN ATOMS AND STRINGS
PRXFLG==400000 ;USE RADIX FOR NUMBERS
;MACROS AND DEFS
;RMAP1 TO BE USED WHEN PAGE MAY NOT EXIST OR MAY BE PRIVATE
IFDEF MAXC,<
DEFINE RMAP1
< RMAP>
>
IFNDEF MAXC,<
DEFINE RMAP1
< CALL RMAPX>
>
DEFINE SETK20
< SETZM KL20F
IFNDEF MAXC,<JSP 7,STKL20>
>
OPDEF CALL [PUSHJ CP,0]
OPDEF RET [POPJ CP,0]
;CAR AND CDR
;A IS DESTINATION ACCUMULATOR
;Y IS SOURCE, AC OR STORAGE
DEFINE CARA (A,Y)
< BB=0
IFG Y,<
IFL Y-20,<
BB=-1
HRRZ A,0(Y)>>
IFE BB,<
HRRZ A,@Y>>
DEFINE CDRA (A,Y)
< BB=0
IFG Y,<
IFL Y-20,<
BB=-1
HLRZ A,0(Y)>>
IFE BB,<
HLRZ A,@Y>>
;TYPE QUOTED STRING
DEFINE TYPEQ (A)
< TMSG [SIXBIT @A/@]>
DEFINE TYPEFQ (A)
< TMSGF [SIXBIT @A/@]>
;UNSTEP BYTE POINTER
DEFINE UBP (A)
< BB==0
IFG A,<
IFL A-20,<
BB=-1
ADD A,[7B5]
SKIPG A
ADD A,[35B5-1]>>
IFE BB,<
EXCH 1,A
UBP 1
EXCH 1,A>>
;STRING POINTER TO BYTE POINTER CONVERSION
DEFINE SBPC (C,B)
< MOVE C,0(B)
IFE B-C,<PUSH CP,C>
TLZ C,777770
IDIVI C,5
HLL C,CBTAB-1(C+1)
IFE B-C,<POP CP,C+1>
IFN B-C,<MOVE C+1,0(B)>
LSH C+1,-↑D21>
;UNBOXED STRING POINTER CONVERSION
DEFINE USBPC (C,B)
< MOVE C,B
IFE B-C,<PUSH CP,C>
TLZ C,777770
IDIVI C,5
HLL C,CBTAB-1(C+1)
IFE B-C,<POP CP,C+1>
IFN B-C,<MOVE C+1,B>
LSH C+1,-↑D21>
;GET VALUE CELL FROM ATOM
DEFINE GTVALC (A,B) <HRRZ A,2(B)>
;SET VALUE CELL OF AN ATOM
DEFINE STVALC(A,B) <HRRM A,2(B)>
; PUT NAME ON STACK, A=ATOM, B=DEST.
DEFINE PUTNAM(A,B)
< GTVALC 8,A ;;GET VALUE CELL
SKIPN 8 ;;GOT ONE?
CALL NEWVC'A ;;NO - GO GET A NEW ONE
BINDIT 8,B,A
>
; BIND A VARIABLE, A=VALCELL, B=DEST, C= A TEMP
DEFINE BINDIT(A,B,C)
< HRRZ C,(A) ;;GET OLD VALUE
HRLI C,(A) ;;PUT IN CELL PTR
EXCH C,B ;;PUT ON STACK, GET NEW VALUE
HRRM C,(A) ;;STORE NEW VALUE
>
;DEFINE STORAGE WORD OR BLOCK
DEFINE U (A,B)
< A=BEGTMP+ZZ
IFB <B>,<ZZ=ZZ+1>
IFNB <B>,<ZZ=ZZ+B>>
ZZ=0
IFNDEF BEGTMP,<BEGTMP==34000>
;LOAD TYPE NUMBER INTO AC
;A-DESTINATION AC, C-SOURCE AC IF SUPPLIED
IFDEF MAXC,<
OPDEF BLDT [116B8]
DEFINE LDT(A,C)
< IFNB <C>,<BLDT A,(C)>
IFB <C>,<BLDT A,(A)>
>
>
IFNDEF MAXC,<
DEFINE LDT (A,C)
< IFNB <C>,<
HRRZ A,C>
LSH A,-LPS
HRRZ A,TYPTAB(A)>
>
;SKIP TYPE EQUAL, NOT EQUAL
;A-SOURCE AC, B-TYPE
DEFINE STE (A,B)
< LDT TP,A
CAIE TP,B'T>
DEFINE STN (A,B)
< LDT TP,A
CAIN TP,B'T>
;FUNCTION CALL FROM HAND CODE
DEFINE LCALL (FN,NA)
< MOVEI 1,NA
MOVE 2,FN
PUSHJ CP,EFNCAL
>
;PUSH NUMBER(S)
DEFINE PUSHN (A,B)
<IFNB <B>,< PUSH CP,[XWD NMBLIP,B]>
IFB <B>,< PUSH CP,[XWD NMBLIP,1]>
PUSH CP,A
>
DEFINE POPN (A)
< POP CP,A
SUB CP,BHC+1
>
;ERROR CALL
;LOC IS LOCATION TO CONTINUE
;N IS ERROR NUMBER
;ERROR1 SUPPLIES VALUE IN AC1
DEFINE ERROR1 (N,LOC)
< PERR <N&17>,LOC+<N&60>B24>
;ERROR0 SUPPLIES NO VALUE
DEFINE ERROR0 (N,LOC)
< PERR0 <N&17>,LOC+<N&60>B24>
;TERMINAL INTERRUPT STUFF
IFN TEN50,<
DEFINE SETICH
< MOVEI 1,20000
TTCALL 6,1 ;READ LINE STATUS
HRLI 1,400020 ;TELMOD (400000) + TELISP (20) BITS
TTCALL 7,1 ;SET LINE STATUS
>
DEFINE CLRICH
< MOVEI 1,20000
TTCALL 7,1
>
;VARIOUS SYSTEM OPS
OPDEF TIME [CALLI 1,23] ;READ CLOCK IN MS
OPDEF CLRTIB [TTCALL 11,0] ;CLEAR TTY IN BUF
OPDEF CLRTOB [TTCALL 12,0] ;CLEAR OUTPUT BUFFER
OPDEF SKIBNE [TTCALL 13,0] ;SKIPE IN IN BUF NOT EMPTY
OPDEF BOUT [PUSHJ CP,CIO] ;BYTE OUT
OPDEF BIN [PUSHJ CP,CIO] ;BYTE IN
OPDEF CORE [CALLI 2,11] ;SET CORE LIMIT
OPDEF HALTF [CALLI 12]
DEFINE GETJRT
< MOVEI 1,0 ;INDICATE CURRENT JOB
CALLI 1,27 ;GET JOB RUN TIME
>
> ;CLOSES IFN TEN50
IFE TEN50,<
JOBSA==120
DEFINE SETICH
< CALL SETINT
>
DEFINE CLRICH
< MOVE 7,CTCTP ;DEASSIGN TERMINAL INTERRUPT CODES
HLRZ 1,0(7)
TRNN 1,400000 ;MAKE SURE IT'S REALLY THERE
DTI
AOBJN 7,.-3
>
DEFINE GETJRT
< MOVEI 1,-5 ;INDICATE WHOLE JOB
RUNTM ;GET JOB RUN TIME
>
DEFINE CLRTIB
< MOVEI 1,100
CFIBF>
DEFINE CLRTOB
< MOVEI 1,101
CFOBF>
DEFINE SKIBNE
< MOVEI 1,100
SIBE
SKIPA>
>
;UUO DEFINITIONS
OPDEF TMSG [1B8]
OPDEF TCH [2B8]
OPDEF PERR [3B8]
OPDEF PSTE [4B8]
OPDEF PSTN [5B8]
OPDEF PSTB [6B8]
OPDEF PSTNB [7B8]
HCCALV==10
OPDEF HCCAL0 [10B8]
OPDEF HCCAL1 [11B8]
OPDEF HCCAL2 [12B8]
OPDEF HCCAL3 [13B8]
OPDEF EXCAL [14B8]
OPDEF CCALL [15B8]
OPDEF PBIND [16B8]
OPDEF PBIND2 [17B8]
OPDEF PIBOX [20B8]
OPDEF PIUNBX [21B8]
OPDEF PSETN [22B8]
OPDEF PERR0 [23B8]
OPDEF LNCALL [24B8]
OPDEF LNCAL2 [25B8]
OPDEF CKUDT [26B8]
OPDEF PSTEI [27B8]
OPDEF PSTNI [30B8]
OPDEF SBCAL [31B8]
OPDEF ACCALL [32B8]
OPDEF ALNCAL [33B8]
OPDEF TMSGF [34B8]
OPDEF TCHM [35B8]
;GLOBAL STORAGE
U TYPTAB,NPM ;TABLE OF DATA TYPES AND STATUS
U ATOMHT,MAXNHT+1 ;TABLE OF HASH TABLE PAGES
U NHP ;CURRENT # HASH TABLE PAGES
U IBOXCN ;INTEGER BOX COUNT
U FBOXCN ;FLOATING BOX COUNT
U ENDCOR ;END OF ASSIGNED CORE
U NEWCNS ;CONS - LOWEST PAGE WITH SOME FREE WORDS
U LSTCNS ; - LAST CONS
U CNSCNT ; - CONS COUNT
U FREBRK ; - BREAK WHEN FREBRK=FRECNT
U CMINWP ;CONTAINS MINWPP FOR CONS
U OFRECT
U MAXATL ;MAX NUMBER OF CHARS IN ATOM (USER SET)
U LINSIZ ;MAX NUMBER OF CHARS PER OUTPUT LINE
U URADIX ;CURRENT OUTPUT RADIX
U ESCONF ;ESCAPE CHAR FLAG - 0=OFF -1=ON
U RMONF ;READMACRO FLAG - 0=OFF -1=ON
U KNIL
U KT
U KNOB
U KLAM
U KNLA
U KPROG
U KPER
U KFNARG
U KINPUT
U KOUTPUT
U KORIG
U KCTRLU
U KSYSHS
U KCLSPA
U KEVAL
U KLPT
U KCOREV
U KRLBLK
U KFORM
U KTAIL
U KFN
U KAVAL
U KPLFLG
U KTENEX
U KTOP20
U KPRINT ;FUNCTIONS CALLED INTERNALLY
U KREADX
U KAPPLY
U KAPP.
U KEVLQT
U KFAULT
U KFALTA
U KERRX
U KESGAG
U KERSET
U KINT
U KSTVAL
U CURRDT ;READTABLES
U SYSRDT
U CURRT2
U SYSRT2
U PRVIRT
U PRVORT
U BSTAB
U PBTAB
U TTYTBL ;CURRENT TERMINAL TABLE
U KPRXFL ;RADIX FLG FOR INTERNAL PRINT
U HLDMSG ;USER HEARLD MESSAGE
U KPRGLM
U KENV ;NAME FOR DUMMY ENVIRONMENT FRAMES
; for TYPENAME of arrays:
U KHARRP ; HARRAYP
U KRDTBP ; READTABLEP
U KARRAP ; ARRAYP
U KTRMTP ; TERMTABLEP
U KCCODP ; CCODEP
; Following atoms needed by byte lisp opcodes which just
; trap and do function call; used in BYTE.MAC
U KHELP ; HELP
U KRPLCA ; RPLACA
U KRPLCD ; RPLACD
U KSET ; SET
U KEVALV ; EVALV
IFDEF MAXC,<MAXCU>
; USER GC MESSAGES
U GCMES1
U GCMES2
U GCMES3
U GCMES4
U GCMES5
U GCMES6
U GCMES7
NKCELL==GCMES7+1-KNIL ;NUMBER OF K-ATOM CELLS
U FILEA,NFILES+1 ;LAST CHAR READ,,FILE NAME ATOM
U FILEN,NFILES ;STATUS FLAGS,,FILE NUMBER
U FCHAR,NFILES+1 ;FILE DATA- FLAGS,,ONE CHARACTER BUFFER
U CHPOS,NFILES ; - PAGE POSN,,LINE POSN
; THE NFILES+1 IS TO LEAVE ROOM FOR STRING INPUT
U FRX ;CURRENT READ AND PRINT FILE INDEX
U FPX
U LOGTOD ;LOGIN TIME-OF-DAY
U LOGRT ;LOGIN RUN-TIME
U GCRT ;GARBAGE COLLECTOR RUNTIME
U FNCALL ;XCT 1(2) OR CALL XBREAK
U FR ;STANDARD READ AND PRINT FILES
U FP
U ICP ;INITIAL STACK VALUES
U ICPC ;CONTROL STACK CONSTANT
U IPP
U IPPC ;PARAMETER STACK CONSTANT
U IREDPP
U IREDCP
U BGNCOR ;BEGINNING OF DATA SPACE
;ABSOLUTE ASSEMBLY OF PAGE 0. BOOTSTRAP TO GET IN THE BOOTSTRAP TO
;GET IN REST OF WORLD, & SOME DATA NEEDED BY SECOND BOOTSTRAP SUCH AS
;SYSDAT, BUFFER FOR FORKHANDLES.
LOC 140
BBOOT:
SKIPA
;NEXT WRD IS USED BY BOOTSTRAP TO FIND RETURN CODE FROM SYSIN
JRST SYSINR
HRLZI 1,400000 ;THIS FORK PAGE 0 (RIGHT HERE)
RMAP ;IS JFN FOR SELF
HLRZ 6,1 ;SAVE IT
MBOOT: HRLZI 1,100001 ;ENTER HERE FROM SYSDN1 AFTER MAKESYS
HRROI 2,BOOTNM
GTJFN
JRST BLOSE
HRLI 1,400000
GET
HRRZI 1,(6) ;RETRIEVE JFN FOR SELF
JRST 777000 ;GOTO BOOTSTRAP
BLOSE: HRROI 1,BLOSM
PSOUT
HALTF
JRST .-1
;THESE MUST BE ON PAGE 0 TOO SO DIDN'T MAKE THEM LITERALS.
BLOSM: ASCIZ /CANNOT FIND <LISP>BOOT.SAV/
BOOTNM: ASCIZ /<LISP>BOOT.SAV/
LOC 1000-↑D48
MYJFNS: 0
MYFRKS: BLOCK 20
DADDYN: ASCIZ /<LISP>BOOT.SAV/ ; INITIALLY SYSOUT ON DUMMY FILE
LOC 777
DATEWD: 0 ;REALLY CALLED SYSDAT.
RELOC
COREV:
;UUO ROUTINE
POPDSP: IFDEF MAXC,<UPSHJ CP,POPTAB>
IFNDEF MAXC,<
PUSHJ CP,POPCL ;C(41)
POPCL: HLRZ TP,40
LSH TP,-↑D9
JRST @POPTAB(TP)
>
;ARGS TO UUO'S
U UUARG1
UUACP: POINT 4,40,12 ;BYTE POINTER TO UUO AC FIELD
;UUO DISPATCH TABLE
POPTAB: EXP UUUOQ,TMSGQ,TCHQ,ERRQ,STEQ,STNQ,STBQ,STNBQ
EXP HCAL0Q,HCAL1Q,HCAL2Q,HCAL3Q,EXCALQ,FNCALQ
EXP BINDQ,BBINDQ
EXP IBOXQ,IUBQ,SETNQ,ERR0Q,LCALQ,LCALQ2,CKTUSE
EXP STEI,STNI,SBCALQ,FNACAL,ALCALQ,TMSGFQ,TCHMQ
REPEAT 4,<EXP UUUOQ>
TRPX: SKIPA 1,[POINT 7,[ASCIZ /CAN'T CONTINUE/]]
UUUOQ: HRROI 1,[ASCIZ /ILLEGAL UUO/]
PSOUT
TRPHLT: HALTF
SKIPL NOFLG ; INTERRUPTS OK?
JRST TRPX
UJSERR: MOVEI 1,400000 ; THIS FORK
GETER
MOVEI 1,(2)
CALL MKN
ERROR1 0,R
;TABLE OF FULL WORD CONSTANTS
XX=-30
REPEAT 30,<EXP XX*1000001
XX=XX+1>
BHC: REPEAT 140,<EXP XX*1000001
XX=XX+1>
;TABLE OF 7 BIT BYTE POINTERS
POINT 7,0,-1
CBTAB: POINT 7,0,6
POINT 7,0,13
POINT 7,0,20
POINT 7,0,27
POINT 7,0,34
;UUO-CALLED ROUTINES
;MESSAGE TYPER
TMSGQ: PUSH CP,[TCO] ;THE OUTPUT ROUTINE TO USE
PUSH CP,1
HRRZ 1,40 ;ADDRESS OF STRING
PUSH CP,2
MOVEI 2,1
HRLI 1,440600
MOVEM 1,UUARG1 ;BYTE POINTER TO STRING
TMSG1: ILDB 1,UUARG1
ADDI 1,40 ;CONVERT TO ASCII
CAIN 1,"$" ;$ BECOMES EOL
JRST TMSG3
CAIN 1,"/" ;SLASH TERMINATES
JRST TMSG2
TMSG4: CALL @-2(CP)
JRST TMSG1
TMSG3: MOVEI 1,EOL
JRST TMSG4
TMSG2: POP CP,2
POP CP,1
SUB CP,BHC+1
RET
;I/O TO CONTROL TELETYPE
TCO: PUSH CP,FX
MOVEI FX,1
CALL FOUT
POP CP,FX
RET
TCI: PUSH CP,FX
MOVEI FX,0
CALL FIN1 ;DON'T INVOKE LINE EDITOR
POP CP,FX
RET
; MESSAGE TYPER THAT USES CURRENT FX
TMSGFQ: PUSH CP,[FOUT]
JRST TMSGQ+1
EOLM: SIXBIT '$/'
;SKIP ON TYPE EQUAL TO C(E) OF UUO
STE1Q: MOVEI TP,0(1)
JRST .+3
STEQ: LDB TP,UUACP ;GET AC FIELD
HRRZ TP,0(TP)
LDT TP
CAIN TP,@40
RSKP: AOS 0(CP) ;EQUAL - SKIP RETURN
RET
;SKIP TYPE NOT EQUAL
STN1Q: SKIPA TP,[1]
STNQ: LDB TP,UUACP
HRRZ TP,0(TP)
LDT TP
CAIE TP,@40
AOS 0(CP)
RET
;SKIP IF TYPE BETWEEN C(E) OF UUO AND SMALLT
;USED FOR ATOM NUMBERP AND FIXP
STBQ: LDT TP,1
CAIGE TP,@40
RET
CAIG TP,SMALLT
AOS 0(CP)
RET
;SKIP IF TYPE NOT BETWEEN C(E) OF UUO AND SMALLT
STNBQ: LDT TP,1
CAIL TP,@40
CAILE TP,SMALLT
AOS 0(CP)
RET
;ERROR IF TYPE NOT EQUAL TO RH(C(E))
;USED BY COMPILED CODE BEFORE SETING A USER DATA TYPE FIELD
CKTUSE: MOVEM 1,UUARG1 ;SAVE POINTER
LDT 1
HRRZ 2,@40
CAIN 1,-ASZ(2) ;IS TYPE CORRECT?
JRST CKUOK ;YES- RETURN
PUSH CP,40 ;NO, SAVE LOC. 40
MOVE 1,UUARG1 ;GET ARG.
ERROR1 40,.+1 ;GENERATE AN ERROR
POP CP,40 ;RESTORE LOC. 40
JRST CKTUSE ;TRY AGAIN
;SKIP IF TYPE OF 1 EQUALS RH(C(E)) OF UUO
STEI: MOVEM 1,UUARG1
LDT 1
HRRZ 2,@40
CAIN 1,-ASZ(2)
AOS 0(CP)
MOVE 1,UUARG1
RET
;SKIP IF NOT EQUAL
STNI: MOVEM 1,UUARG1
LDT 1
HRRZ 2,@40
CAIE 1,-ASZ(2)
AOS 0(CP)
CKUOK: MOVE 1,UUARG1
RET
;BIND ARGS - EFF. ADDR OF UUO IS ADDRESS OF ARG NAMES AND CONSTANTS
;BYTES 9 #NAMS #CONST FRAMSIZ DEPTH
BINDQ: HRRZ 7,0(CP)
AOS 0(CP) ;RET FROM PROG FRAME TO 1 PAST BIND
MOVE 3,BINDP1
LDB 1,3
ADDI 1,@40
ILDB 2,3
JUMPE 2,BINDC1
MOVN 2,2
HRLI 1,(2)
HRRZ 2,(1)
PUSH PP,2 ;PUSH CONSTANTS
AOBJN 1,.-2
BINDC1: ILDB 1,3 ;FRAM SIZE
ILDB 6,3 ;BINDING DEPTH
MOVE 4,KPRGLM ;HOKEY NAME FOR PROG/LAM
JSP 5,CFRAM ;GO MAKE A FRAME
HRRZ 3,CF
BINDC6: GETAL 3,3
HLRZ 2,3(3) ;GETPPO 2,3
HLRZ 2,(2) ;... 'CAUSE GETPPO ISNT DEFINED YET
PUSH PP,2
PUSH PP,0(3)
SOJG 6,BINDC6
MOVE 3,BINDP1
LDB 1,3
MOVEI 2,@40
MOVE 6,[Z 1(VP)]
JUMPE 1,BINDC
MOVN 1,1
HRLI 2,0(1)
BINDC2: MOVE 4,0(2)
TLNE 4,-1 ;LH NON-ZERO MEANS LOCAL VAR(UNNAMED)
JRST BINDC3
BINDIT 4,@6,5
BINDC3: ADDI 6,1
AOBJN 2,BINDC2
BINDC: ILDB 1,3
JUMPE 1,2(7)
MOVN 1,1
HRLI 2,0(1)
BINDC5: HLRZ 4,0(2)
TRNN 4,-1
JRST BINDC4
BINDIT 4,@6,5
BINDC4: ADDI 6,1
AOBJN 2,BINDC5
JRST 2(7)
BINDP1: POINT 9,0(7),8
;BINDER FOR BLOCKFN THAT MAKES A FRAME
;EFF ADDR OF UUO IS ADDR OF LITS - FIRST LIT IS FN NAME
;REST ARE ARGNAME,,ARG#
;BYTES 9 ARGTY FRAMSIZ 0 #LITS
;IF FN IS LAMA THEN AC1 HAS # ARGS GIVEN.
; - ARGTY IS OBSOLETE - NO LONGER USABLE FOR LAMBDA*
BBINDQ: POP CP,7 ;EXTRA RETURN DUE TO UUO
PUSH CP,[R] ;TO MAKE SURE THE FRAME IS NOT "SHORT"
HLRZ 1,0(7) ;FRAMESIZE
ANDI 1,777
BB5: MOVE 4,@40 ;FN NAME
JSP 5,CFRAM ;MAKE FRAME
MOVEI 2,@40
MOVN 3,0(7) ;NEG # LITS (INCL. FN NAME)
HRLI 2,0(3)
AOBJP 2,1(7)
BB2: HRRZ 3,0(2) ;PUT NAMES IN FOR SPECVARS
ADDI 3,-ASZ(VP)
HLRZ 4,0(2) ;GET VALUE CELL
BINDIT 4,0(3),5 ;BIND THE VARIABLE
BB1: AOBJN 2,BB2
JRST 1(7)
BB4: MOVEI 4,ASZ(1)
PUSH PP,4
AOJA 1,BB5
;BOX EFF ADR FROM COMPILED CODE
IBOXQ: HRRZ 1,@40
CAIGE 1,MSN/2
CAMG 1,[-MSN/2]
JRST MKN1
ADDI 1,ASZ
RET
;UNBOX EFF ADR FROM COMPILED CODE
IUBQ: HRRZ 1,@40
IUBQ1: LDT 2,1
CAIN 2,SMALLT
JRST IUBQS
CAIE 2,FIXT
JRST IUBQ2
MOVE 1,0(1)
RET
IUBQS: SUBI 1,ASZ
RET
IUBQ2: CAIE 2,FLOATT
JRST IUBQE
MOVE 1,0(1)
JRST FLTFX
IUBQE: ERROR1 12,.+1
JRST IUBQ1
;SETN FROM COMPIILED CODE, E OF UUO IS VAR LOC
;AC1 NUMBER, 2 TYPE
SETNQ: HRRZ 4,@40 ;OLD VALUE(PTR)
LDT 5,4
CAIE 5,FIXT
CAIN 5,FLOATT
JRST SETN1
PUSH CP,40 ;GC CAN CLOBBER
CALL GBOX ;BOX NEW
POP CP,40
HRRM 1,@40 ;STORE NEW VAL(PTR)
RET
SETN1: MOVEM 1,0(4) ;STORE NEW VAL IN OLD BOX
MOVEI 1,0(4) ;RET PTR
RET
;ERROR ROUTINES
;ERROR UUO
ERR0Q: MOVEI 1,0
ERRQ: MOVEM 1,ERRVAL ;MESSAGE VALUE
LDB 1,UUACP ;LOW ORDER 4 BITS OF ERROR NUMBER
MOVEM 1,ERRNM
LDB 1,[POINT 2,40,20] ;HIGH ORDER 2 BITS
LSH 1,4
IORM 1,ERRNM
HRRZ 1,40 ;CONTINUE LOCATION
TRZ 1,300000 ;FLUSH NUMBER BITS
MOVEM 1,0(CP) ;REPLACES UUO RETURN ON STACK
TRNE F,RMFLG ;READ BLIP?
PUSH PP,[READ,,0] ;YES - MAKE SURE READMACROS ARE OFF
LCALL KERRX,0 ;CALL ERRORX
HLRZ 2,(PP) ;READ BLIP?
CAIN 2,READ
SUB PP,BHC+1 ;YES - DELETE IT.
RET
;SIMPLE ERRORX IF NO EXPR LOADED
ERRX: HRRZ 1,CF
CALL FERSET ;LOOK FOR ERRORSET
JUMPE 1,ERRX1 ;NO ERRORSET
PUSH CP,1 ;SAVE ERRORSET POSITION
HRRZ 2,@KESGAG ;TEST ESGAG
CAMN 2,KT
JRST ERRX3 ;T => PRINT MESSAGE AND BACKTRACE
HRRZ 1,0(1)
HRRZ 1,2(1) ;ERRORSET (2ND ARG) FLAG
CAMN 1,KNIL
JRST ERRX4 ;NO MESSAGE
ERRX3: CALL ERRORN
CALL ERRORM ;PRINT MESSAGES
HRRZ 2,@KESGAG
CAMN 2,KT
CALL BACKTR ;T => DO BACKTRACE
ERRX4: POP CP,1
JRST ERRF1 ;RETURN NIL FROM ERRORSET
ERRX1: SKIPE ERRDSP
JRST ERRX5 ;ALREADY IN BACKTRACE
CALL ERRORN
CALL ERRORM
ERRX2: CALL BACKTR
ERRX5: SETZM ERRDSP
JRST RESET
U ERRDSP
;GET ERROR NUMBER AND MESSAGE OF LAST ERROR
ERRORN: MOVE 1,ERRVAL ;MESSAGE
MOVE 2,KNIL
JUMPE 1,ERRN1 ;NO MESSAGE
CALL CONS
MOVEI 2,0(1)
ERRN1: MOVE 1,ERRNM ;NUMBER
ADDI 1,ASZ ;BOX IT
JRST CONS
U ERRVAL
U ERRNM
;PRINT ERROR DIAGNOSTIC AND MESSAGE
ERRORM: PUSH PP,1
CARA 1,1 ;ERROR NUMBER
CALL IUNBOX
JUMPL 1,FALSE ; CHECK FOR OUT OF RANGE
CAIL 1,ERRMT1-ERRMT
JRST FALSE
TMSG EOLM
TMSG @ERRMT(1) ;DIAGNOSTIC
TMSG EOLM
POP PP,1
CDRA 1,1
CAMN 1,KNIL ;MESSAGE?
RET ;NO
CARA 1,1
JRST PRINTX
; CONVERT ERROR NUMBER TO STRING
ESTRNG: CALL IUNBOX
JUMPL 1,FALSE ;CHECK FOR OUT OF RANGE
CAIL 1,ERRMT1-ERRMT
JRST FALSE
HRRZ 1,ERRMT(1)
HRLI 1,440600
PUSH CP,1
CALL MKSTRS
ESTRN3: ILDB 1,0(CP)
CAIN 1,"/"-40 ;THE CHAR / TERMINATES ERROR MESSAGES
JRST ESTRN2
ADDI 1,40 ;CONVERT TO 7 BIT
CALL MKSTR1
JRST ESTRN3
ESTRN2: SUB CP,BHC+1
MOVE 1,UNP1
JRST MKSP
;SET ERROR NUMBER
SERRN: MOVEM 2,ERRVAL
CALL IUNBOX
MOVEM 1,ERRNM
JRST FALSE
;ERRORSET
ERRSET: CALL EVAL
MOVE 2,KNIL ;RETURN LIST OF VALUE
JRST CONS
;ERROR! DOES QUICK RETURN TO ERRORSET
ERRORE: JSYS INTFX ;FROM ↑E
ERRORF: HRRZ 1,CF
CALL FERSET ;FIND IT
JUMPE 1,SRESET ;NO ERRORSET SO RESET
ERRF1: HRRZ 2,KNIL
JRST RETU2
ERROR: ERROR1 21,R ;USER INITIATED ERROR
;FIND ERRORSET - 1 HAS IPOS TO BEGIN LOOKONG
FERSET: MOVEI 3,0(1)
HRRZ 1,KERSET
MOVNI 2,1 ;THE FIRST
JRST STKPOS
;BACKTRACE(FROM TO N FILE ARGPRINTFN)
;BITS IN N - 1 PRINT ARGS, 2 PRINT FORMS, 40 PRINT JUNK
;10 DONT PRINT UNTRACE: OR FN NAME, 20 CHASE ALINKS,
;4 PRINT SUBR ARGS
UBAKTR: CALL STKGP
JUMPE 1,STKER1
PUSH PP,1
HRRZ 1,2(VP)
CAMN 1,KNIL ;DEFAULT EPOS IS TOP
HRRZ 1,KT
CALL STKGP
JUMPE 1,STKER2
POP PP,7 ;BEG
MOVEI 6,0(1)
HRRZ 3,3(VP) ;FLG
HRRZ 2,4(VP) ;FILE
HRRZ 4,5(VP) ;ARGPRINTFN
CAMN 4,KNIL
SETZ 4,
JRST BT
BACKTR: HRRZ 1,KT
CALL STKGP ;GET TOP
MOVEI 6,0(1)
HRRZ 7,CF ;WHOLE STACK
MOVEI 3,ASZ+1 ;PRINT VARS, NO FORMS, NO SUBR ARGS
MOVE 2,KT ;OUTPUT TO TTY
BT: SETOM ERRDSP ;SET FLAG FOR ERRORX
PUSH PP,4
CAMN 3,KNIL
MOVEI 3,ASZ+1 ;STANDARD IS VARS, NO FORMS NO SUBR ARGS
MOVEI TF,-ASZ(3) ;SETUP TEMP FLAGS
CALL OFSET
TRNN TF,10
TYPEFQ <$UNTRACE:$>
MOVE 2,BTPC
TRNE TF,20
MOVE 2,BTPA
MOVEM 2,STKPX
BT10: JUMPE 7,BTVR
TRNN TF,42 ;PRINTING EVAL BLIPS OR JUNK?
JRST BTV3 ;NO
TRZ F,NEGFLG
GETPPI 3,7
HRRZ 4,PP
CAMN 7,CF
JRST BTV2
GETCPO 4,7
HLRZ 4,0(4) ;PPO
BTV2: SUBI 4,0(3)
HRLI 3,4
JUMPE 4,BTV3 ;NO TEMS
BTV1: HLRZ 1,@3
CAIN 1,EVBLIP
JRST BTEV
TRNN TF,40 ;JUNK WANTED TOO?
JRST BTV3 ;NO
MOVE 5,[XWD -NBLIPS,BLIPTB]
BTV12: HLRZ 2,0(5)
CAIE 2,0(1)
JRST BTV13
HRRZ 1,0(5)
SKIPA 1,0(1)
BTV13: AOBJN 5,BTV12
BTV11: CALL BTNV ;PRINT 'NAME AND VALUE
SOJG 4,BTV1
BTV3: TRNN TF,1 ;PRINTING BINDINGS?
JRST BTN ;NO
HRRZ 3,0(7) ;BEG ARRGS -1
GETNAR 4,7
JUMPE 4,BTN ;NO ARGS
HRLI 3,4
TRZ F,NEGFLG
BTV31: HLRZ 1,@3
STE 1,VCELL
JRST BTV32 ;FUNNY ARG NAME
CALL BTARG ;PRINT NAME AND VALUE
BTV33: SOJG 4,BTV31
BTN: TRNE TF,10
JRST BT2 ;SUPPRESS NAME
HRRZ 3,0(7)
GETNAR 4,7
ADDI 3,0(4)
HRRZ 1,1(3)
STE 1,ATOM
JRST BTN1 ;FUNNY FN NAME
CALL SAV27
HRRZ 2,FILEA(FX)
HRRZ 3,KT
CALL PRINT
CALL RES27
SKIPA
BTN1: TYPEFQ <***$>
BT2: CAIN 7,0(6)
JRST BTVR
XCT STKPX
JRST BT10
BTV32: TRNN TF,4 ;PRINT SUBR ARGS??
JRST BTV33 ;NO
HRRZ 1,@3
TRON F,NEGFLG
TCH EOL ;BLANK LINE BEFORE FIRST ARG
TYPEFQ < > ;INDENT
TYPEFQ <*ARG> ;USE ARG# FOR UN-NAMED ARGS
MOVEI 2,@3
SUB 2,0(7)
TCH "0"(2) ;ARG #
CALL BTPV ;PRINT SPACE AND VALUE
JRST BTV33
BTEV: HRRZ 1,KFORM
JRST BTV11
BTNV: TRON F,NEGFLG
TCH EOL
TYPEFQ < >
CALL SAV27
HRRZ 2,FILEA(FX) ;GET FILE NAME
MOVE 3,KT
CALL PRIN2
CALL RES27
BTPV: TCH " "
HRRZ 1,@3
CALL SAV27 ;SAVE AC'S 2-7
HRRZ 2,FILEA(FX) ;GET FILE NAME
HRRZ 3,KT
SKIPE 0(PP) ;HAVE A PRINT FN?
JRST BTPX2 ;YES
CALL PRINT
JRST BT1Y
BTPX2: PUSH PP,0(PP) ;PUSH FN NAME
PUSH PP,1 ;AND ARGS
PUSH PP,2
PUSH PP,3
MOVEI 1,3
CALL EVCC ;CALL THE FN
BT1Y: CALL RES27
RET
BTVR: SETZM ERRDSP
JRST TRUE ;RETURNS T IF NORMAL, NIL IF INTERRUPTED
BTPC: GETCL 7,7
BTPA: GETAL 7,7
BTARG: PUSH PP,6
PUSH PP,7
PUSH PP,4
PUSH PP,3
PUSH PP,1
MOVEI 1,@3
MOVEI 2,(7)
CALL FNDBND
POP PP,1
PUSH PP,3
CALL VCTOAT
POP PP,3
PUSH PP,-4(PP) ;PRINT FN MUST BE ON TOP OF PP
CALL BTNV
SUB PP,BHC+1 ;FLUSH PRINT FN COPY
POP PP,3
POP PP,4
POP PP,7
POP PP,6
RET
BLIPTB: XWD EVBLIP,KFORM
XWD PRBLIP,KTAIL
XWD AVBLIP,KAVAL
XWD FNBLIP,KFN
XWD FNBLIP+1,KFN
XWD FNBLIP+2,KFN
XWD FNBLIP+3,KFN
NBLIPS==.-BLIPTB
;INTERRUPT ROUTINES
DEFINE EINT
< IFE TEN50,<
JSYS EINTR ;ENTER INTERRUPTED STATE
>>
DEFINE EINT1
< IFE TEN50,<
JSYS EINTR1
>>
DEFINE INTOFF
< AOS NOFLG
>
DEFINE INTON
< XCT INTONX
>
INTON1: XWD INTONR,.+1
SKIPG NOFLG ;INTERRUPT OK NOW?
JRST .+3
SOS NOFLG ;NOT YET
JRST @INTONR
MOVE 1,RSTONX ;RESTORE SWITCH
MOVEM 1,INTONX
RSTONX: SOS NOFLG
JRST @GINTD ;AND GO DO IT
;FIXUP BEFORE CALLING A FUNCTION AFTER AN INTERRUPT
INTFX: XWD INTFXX,.+1
INTOFF
SKIPG TP,CF
0 ;THIS SHOULDNT HAPPEN - CATCH
HRLI CP,@ICPC
HRLI PP,@IPPC
CAILE TP,-FLGWD(CP) ;PARTIAL FRAME?
JRST INTFX1 ;YES
INTFX2: HRRZ TP,CF ;NOW MAKE SURE BASIC FRAME IS OK
GETPPI 7,TP
JUMPN 7,INTFX4
CAMN TP,LSTSWF ;FLUSHING THE CURRENT SWAPPED FRAME?
SETZM LSTSWF ;YES, CLEAR IT.
GETBAS PP,TP ;BACK UP A FRAME
HRLI PP,@IPPC ;FLUSH CURRENT
GETCL 3,TP ;NOT OK - BACK UP A FRAME
MOVEI CP,-1(TP)
HRLI CP,@ICPC
MOVEM 3,CF
GETBAS VP,3
GETCPO 4,3
CAIE 4,0(CP)
JSYS RECP
HLRZ 4,0(CP)
CAIE 4,0(PP)
JSYS REPP
INTFX4: TLNE CP,-1 ;CP FULL? -I.E. ABOUT TO POPJ?
JRST INTFX3
JSP 7,ECOPCO
JRST CPFUL
INTFX3: INTON
JRST @ INTFXX
INTFX1: CAIN TP,-CLWD(CP) ;AT CLINK WORD?
POP CP,3 ;YES - BACK UP TO CLINK OF CF
STE 3,STACK
0 ;CATCH CROCKS
HRRZM 3,CF
JRST INTFX2
U INTFXX
EINTR: XWD EINTRX,.+1
MOVEM CP,RSTCP ;SAVE MAIN STACK
MOVE CP,IIP ;SETUP LOCAL STACK
EINTRA: PUSH CP,RSTCP
PUSH CP,1
JRST @EINTRX
EINTR1: XWD EINTRX,.+1
MOVEM CP,RSTCP
MOVE CP,IIP1
JRST EINTRA
;RETURN FROM INTERRUPT
RSTC: POP CP,1
MOVE CP,0(CP) ;RESTORE STACK, AC'S
DEBRK ;DISMISS INTERRUPT
TRAP: IFDEF MAXC,<
EXCH 7,LPC1
TLNE 7,MD2
JRST BYTRAP ; BYTRAP IS IN BYTE.MAC
EXCH 7,LPC1
> EINT1
HLRZ 1,@LPC1
ANDI 1,777000 ; IF INSTRUCTION AFTER TRAP
CAIE 1,(JFCL) ; JSYS FOLLOWED BY JFCL MEANS CAUSE ERROR
CAIN 1,(JUMP) ; IS A JUMP (INDEPENDENT OF AC FIELD)
JRST TERJMP ; THEN DON'T TRAP
TRAP1: MOVEI 1,TRPHLT
EXCH 1,LPC1
MOVEM 1,TRPLPC
MOVE 1,0(CP)
JSYS SAVTRP ; SAVE ACS
PUSH CP,40
TYPEQ <$TRAP AT LOCATION >
HRRZ 1,TRPLPC
CALL PNO8
POP CP,40
MOVE 1,TRPLPC ; GET OFFENDING INSTRUCTION
HLRZ 1,-1(1) ; PC WAS ADVANCED
ANDI 1,777000
CAIE 1,(JSYS)
JRST TRAPX ; NO, OTHER KIND OF TRAP
TRPJSY: HRROI 1,[ASCIZ/
JSYS ERROR: /]
PSOUT
TRAPX: MOVEI 1,101
HRLOI 2,400000
MOVEI 3,0
ERSTR
JFCL
JFCL
MOVE 2,TRPACS+2
MOVE 3,TRPACS+3
JRST RSTC
TERJMP: CAIN 1,(JUMP) ; IF JUMP INSTRUCTION
SKIPA 1,@LPC1 ; GET ERJMP ADDRESS
MOVEI 1,UJSERR ; ELSE USE STANDARD ERROR ROUTINE
HRRZM 1,LPC1
JRST RSTC
U TRPLPC
U TRPRET
U TRPACS,20
SAVTRP: TRPRET,,.+1
MOVEM F,TRPACS ;SAVE AC'S FROM A TRAP
MOVE F,[1,,TRPACS+1]
BLT F,TRPACS+17
MOVE F,TRPACS
JRST @TRPRET
;WRITE TRAP FIDDLER
WTRP: EINT1
PUSH CP,2
MOVEI 1,400000
GTRPW
PUSH CP,1 ;SAVE TRAP WORRD
PUSH CP,2 ;AND WRITE DATA
MOVEI 1,0(1)
LSH 1,-LPS ;PAGE CAUSING TRAP
CAMN 1,PPTRP
JRST FTRP3 ;MAGIC PP OVERFLOW PAGE
HRLI 1,400000
RPACS
TLNE 2,(1B6) ;INDIRECT PTR?
JRST WTRP3
MOVSI 2,130400 ;NO
SPACS ;CHANGE ACCESS
WTRP5: MOVSI 2,PVTBIT
IORM 2,TYPTAB(1)
WTRP2: POP CP,2
POP CP,1
SKIPE KL20F
JRST WTRPZ
TLNN 1,12 ;WRITE REQUIRED?
MOVEM 2,0(1) ;DO THE OFFFENDING WRITE
WTRPZ: POP CP,2
JRST RSTC
FTRP3: SUB CP,BHC+2
POP CP,2
JRST TRAP1
WTRP3: PUSH CP,1 ;FORK,,PG 1,ACCESS 2
RMAP
TLNN 1,400000
JRST WTRP4 ;NOT A FORK
HRRM 1,0(CP) ;SAVE PAGE #
HLRZ 2,1
HLRZ 1,0(CP) ;GET FORK HANDLE USEABLE IN CURRENT
CALL TGFRKH
JRST WTRP4 ;PUNT
HRLM 1,0(CP)
MOVE 1,0(CP)
RPACS ;GET IMM AND INDIR ACCESS
TLNE 2,(1B6) ;INDIR?
JRST WTRP3+1 ;YES - GO TIL ISNT
WTRP4: POP CP,1
MOVSI 2,130400
SPACS
TLNN 1,377777
JRST WTRP5
CALL FRKHN ;TRANS FORM FORK HANDLE TO NUMBER
MOVEI 2,FPVTBT
CALL SFRKB ;SET PVT BIT
JRST WTRP2
;The following is a temporary GFRKH routine. There are several
;problems. GFRKH is not yet implemented at PARC and other places still
;running Tenex 1.31. It is in 1.32 and versions of 1.31 which are
;close to 1.32, e.g. those at BBN as of this writing, May '74.
;Secondly, thou shalt not do GFRKH's like this without corresponding
;RFRKH's. Otherwise, eventually something like CFORK will refuse
;to work merely for want of a name (400000 - 400030) for its output.
;Finally it is not clear that any case ever arises in which indirect
;page pointer chains go more than one level deep, or that if such cases
;do arise, one wants to chase clear to the bottom. However, that is
;the only approach that guarantees continuation. Even this code would
;lose if the page were ultimately found in a file opened for reading
;only.
;The fix here is to avoid calling GFRKH on the first iteration of the
;loop when it is a NOP anyway ("Give me a fork handle useable in fork
;400000 for the fork which is known as X to another fork I know about,
;namely, myself.). If it ever goes deeper than that, we call GFRKH
;and the hell with it.
TGFRKH: CAIE 1,400000
JRST TGFRK1
HRRZI 1,(2)
JRST .+3
TGFRK1: GFRKH
RET
AOS 0(CP)
RET
;FORK HANDLE,, PG IN 1
;GET FORK#,, PAGE IN 1, 0 IF BAD
FRKHN: PUSH CP,3
MOVE 2,[XWD -NFRKS,FRKHT]
MOVSS 1
FRKHN1: HLRZ 3,0(2)
CAIN 3,0(1)
JRST FRKHN2
AOBJN 2,FRKHN1
HLRZ 1,1
FRKHN3: POP CP,3
RET
FRKHN2: MOVSS 1
HRLI 1,-FRKHT(2)
JRST FRKHN3
U FRKHT,NFRKS
U EINTRX,1
U LPC1,1 ;INTERRUPT LEVEL PC'S
U LPC2,1
U LPC3,1
U NOFLG
U INTONX
U INTONR
;TENEX PSI LEVEL AND CHANNEL TABLES
LEVTAB: XWD 0,LPC1
XWD 0,LPC2
XWD 0,LPC3
CHNTAB: XWD 2,RSTU0 ;USER INTERRUPT
XWD 2,RST1P ;↑P
XWD 2,RST1F ;↑S
XWD 2,RST1R ;RUBOUT
XWD 2,RST1E ;↑E
XWD 2,RST1Z ;↑D
XWD 0,0 ;OVERFLOW
XWD 0,0 ;FLOATING OVERFLOW
XWD 0,0 ;UNUSED
XWD 1,PDLTRP ;PDL OVF
XWD 0,0 ;EOF
XWD 1,TRAP ;DATA ERR
XWD 0,0 ;FILE (UNASSIGNED)
XWD 0,0 ;FILE (UNASSIGNED)
XWD 0,0 ;TOD
XWD 1,TRAP ;INSTRUCTION
XWD 1,WTRP ;MEM READ
XWD 1,WTRP ;MEM WRITE
XWD 1,TRAP ;MEM XCT
XWD 0,0 ;FORK
XWD 0,0 ;MACHINE SIZE
XWD 2,RST1E ;↑C - NORMALLY NOT ACCTIVATED
XWD 0,0 ; UNUSED
XWD 0,0 ; UNUSED
XWD 2,RSTU1 ;USER INTERRUPT
XWD 2,RSTU2 ;DITTO
XWD 2,RSTU3 ;DITTO
XWD 2,RSTU4 ;DITTO
XWD 2,RST1O ;↑O - 28.
XWD 2,RST1H ;↑H
XWD 2,RST1B ;↑B
XWD 2,RSTU5 ;USER INTERRUPT
XWD 2,RSTU6 ;USER INTERRUPT
XWD 2,RSTU7 ;DITTO
XWD 2,RSTU8 ;DITTO
XWD 2,RST1T ; CONTROL-T - INITIALLY OFF
;TABLE TO INIT TERM INTERRUPTS
DEFINE STC (T,C)
< XWD "T"-100,C>
CTCT10: STC H,35
STC P,1
STC S,2
XWD 34,3 ;RUBOUT
STC E,4
STC D,5
STC O,34
STC B,36+400000 ;HARD INTERRUPT
STC T,43 ;CONTROL-T
STC U,0 ;FIRST "USER" INTERRUPT
XWD 400000,30
XWD 400000,31
XWD 400000,32
XWD 400000,33
XWD 400000,37
XWD 400000,40
XWD 400000,41
XWD 400000,42
CTCT20: STC H,35
STC P,1
STC X,2
STC Z,3
STC E,4
STC D,5
STC O,34
STC B,36+400000
STC T,43 ;CONTROL-T
STC N,0 ;FIRST "USER" INTERRUPT
XWD 400000,30
XWD 400000,31
XWD 400000,32
XWD 400000,33
XWD 400000,37
XWD 400000,40
XWD 400000,41
XWD 400000,42
NSCTCT==↑D9 ; NUMBER OF SYSTEM INTERRUPTS
NUCTCT==↑D9 ; NUMBER OF USER INTERRUPTS
NCTCT==NSCTCT+NUCTCT
U CTCT,NCTCT
UCTCT=CTCT+NSCTCT
U UCTVAR,NUCTCT ;THE INTERRUPT VARIABLES
UCTVRP: XWD -NUCTCT,UCTVAR
CTCTP: XWD -NCTCT,CTCT
UCTCTP: XWD -NUCTCT,UCTCT ;FOR JUST LOOKING AT THE USER CHARS.
CTCTC: STC C,25
PDLTRP: EINT1
CALL SAV27
HLRZ 1,IPD1 ;CHECK LEFT SAVED CP
JUMPE 1,PDLTRC ; IF = 0, CP BLEW
TLNE PP,-1 ;OR WAS IT PP
JRST PDLTR2 ;NEITHER JUST ERROR
PDLTPP: JSP 7,ECOPPO ;COPY IF POSSIBLE
JRST IPPFUL ;REALLY FULL - EMERGENCY TOO
JRST PDLTR3
PDLTRC: HRRZ 1,LPC1
IFDEF MAXC,<
CAIE 1,XFNCA
JRST PDLTR5
LDB 1,[POINT 5,CBS,5] ; "State" of CALLFN instruction, where
MOVEI 1,XFNCC-5(1) ; 3 = trap after 1st push, 4 after 2nd, 5 after 3rd
TLZ CBS,370000 ; set state to 5
TLO CBS, 50000
>
IFNDEF MAXC,<
CAILE 1,EFNCAL ;IN CRUCIAL 3 PUSH'S ?
CAILE 1,XFNCA
JRST .+3
ADDI 1,XFNCC-XFNCA ;YES - SWITCH TO RESUME SUCH THAT
>
HRRM 1,LPC1 ;.. RET FLG WILL BE PPRC
PDLTR5: EXCH CP,IPD1 ;GET ORIG. CP BACK FOR A SEC
JSP 7,ECOPCO ;COPY STACK IF POSSIBLE
JRST ICPFUL
PDLTR4: EXCH CP,IPD1
PDLTR3: CALL RES27
JRST RSTC ;GO DEBRK
PDLTR2: MOVEI 1,PDLERR ;SOME OTHER STACK
PDLT22: MOVEM 1,LPC1
JRST PDLTR3
IPPFUL: TRNE F,GCFLG ;PPFULL IN INTERRUPT
JRST ICPBAD
IPPF1: MOVEM CP,IPD1 ;SAVE INTERRUPT CP
JSP 7,RESTK ;NOT IN GC - FOR NOW FLUSH STACK
EXCH CP,IPD1 ;GET INTERUPT CP BACK,SET NEW RUN CP
MOVEI 1,PDLER1
JRST PDLT22
PPFUL: ;STACK REALLY FULL (EMERGENCT TOO)
CPFUL: JSP 7,RESTK ;FOR NOW JUST RESET STACKS
PDLER1: TYPEQ <$STACK OVERFLOW$>
JRST EVQ2
PDLBRK: INTOFF
SKIPG TP,CF ;GET HERE WHEN STACK FULL AND TERM INTS BACK ON
0 ;CATCH CROCKS - SHOULDNT HAPPEN
CAIG TP,-FLGWD(CP) ;PARTIAL FRAME?
JRST PDLBR1 ;NOPE
MOVEI TP,0(CP) ;YES - HAD TO BE IN PROCESS OF MAKING IT
SUB TP,CF
JRST .+1(TP) ;SO FINISH IT
PUSH CP,3
PUSH CP,3
PUSH CP,HCRETC
HRLM 1,-3(CP) ;SET # ARGS
PUSH PP,2 ;AND FN NAME
HRLM PP,-2(CP) ;AND PPI
PDLBR2: INTON
PDLERR: ERROR0 2,RESET
PDLBR1: HRRZ TP,CF ;EXT IS COMPLETE - CHECK BASIC FR.
GETPPI 3,TP
JUMPN 3,PDLBR2 ;PPI IS SET SO OK
MOVEI 3,0(PP) ;PPI NOT SET
SUB 3,0(TP) ;ASSUME EVERYTHING ON PP IS ARGS
HRLM 3,NARWD(TP)
MOVEI 2,0(2)
PUSH PP,2 ;FN NAME - HOPEFULLY - BUT NEED CXT
SETPPI PP,TP
JRST PDLBR2
U STKMOD ;CONTAINS STATE OF STACK
SMPR==1 ;PPSTACK IS IN EMERGENCY REGION
SMCR==2 ;CP STACK IS IN EMERGENCY REGION
SMCM==4 ;CP HAS BEEN MAPPED (DURING GC)
;CP OVERFLOW IN GC - MAP OUT STUFF FROM LCALQ TO CLRBUF
;APPROX 6000Q WDS. TO USE FOR STACK DURING GC
OVCP=LCALQ+777 ;APPROX. BEGINNING (MACRO EATS IT)
OVEND=CLRTTY ;APPROX.END OF TEMP STACK
ICPFUL: EXCH CP,IPD1
TRNN F,GCFLG
JRST IPPF1 ;NOPE
HRRZ 2,IPD1
CAIG 2,OVEND
CAIGE 2,OVCP ;ALREADY USING TEMP STACK?
JRST ICPF4
ICPBAD: HRROI 1,[ASCIZ /STACK BLEW IN GC/]
PSOUT
HALTF
JRST .-1
ICPF4: MOVEI 4,OVEND
LSH 4,-LPS ;LAST PG+1
MOVEI 5,OVCP ;COMPUTE FIRST WD OF STACK
ANDI 5,-NPS
SUBI 5,1 ;FIRST WD-1
MOVEI 1,OVCP
LSH 1,-LPS ;FIRST PG OF STACK
HRLI 1,400000
ICPF3: MOVEM 1,ICPT1
RMAP1 ;PAGE COULD BE PRIVTE IF CONTAINS A BPT!
EXCH 2,ICPT1 ;SAVE ACCESS
MOVEM 1,ICPT2 ;AND MAP
HRREI 1,-1 ;FLUSH PAGES
MOVEI 3,0
PMAP
PUSH 5,ICPT1 ;SAVE ACCESS
PUSH 5,ICPT2 ;AND MAP OF FLUSHED PAGE
AOS 1,2
CAIE 4,0(2)
JRST ICPF3
PUSH 5,CF
HRL 5,CF
AOBJN 5, ;COPY FROM C(CF)+1 TO C(5)+1
HLRZ 4,5 ;CF+1 - FOR HOLE MARK
HRRZ 2,IPD1
SUB 2,CF
HRRM 5,CF
MOVEI 3,0(2) ;LENGTH OF REGION ABANDONING
HRLI 3,STKHOL
ADDI 2,-1(5)
MOVEI 2,0(2)
CAIL 2,OVEND
JRST ICPBAD ;WONT FIT
BLT 5,0(2) ;COPY CP
MOVEM 3,0(4) ;MARK HOLE
MOVEI 3,0(2) ;COMPUTE REMAINING STACK LENGTH
SUBI 3,OVEND
HRLI 2,1(3)
MOVEM 2,IPD1 ;RESET CP FOR DEBRK
JRST PDLTR3
OVFIX: POP CP,5
MOVEI 2,OVEND-NPS
LSH 2,-LPS
MOVEI 4,OVCP-NPS
LSH 4,-LPS
HRLI 2,400000
OVFIX1: POP CP,1
POP CP,3
PMAP
SOS 2
CAIE 4,0(2)
JRST OVFIX1
MOVE CP,5
MOVEM 5,CF
JRST 0(7)
U ICPT1
U ICPT2
RST1P: EINT
CALL RSTRN ;GET NUMBER
ISCTLP: JRST .+2 ;CAR ONLY
JRST RST4P ;CAR AND CDR
PUSH CP,2
RST6P: MOVE 2,RSTSUM
CAIN 1,"."
JRST RST2P ;SET FOR THIS PRINT
CAIE 1,"!"
JRST RST3P ;ABORT
MOVEM 2,PPLVL ;SET PERMANENT LEVEL
RST2P: MOVEM 2,TPLVL
RST3P: POP CP,2
JRST RSTC
RST4P: PUSH CP,2 ;DO CDR
MOVE 2,RTSUM2
EXCH 2,RSTSUM
SUB 2,PPDLVL
CAIN 1,"."
JRST RST5P ;SET THIS LEVEL
CAIE 1,"!"
JRST RST3P ;ABORT
ADDM 2,PPDLVL ;SET PERMANENT LEVEL
RST5P: ADDM 2,TPDLVL
JRST RST6P
RSTRN: SETZM RSTSUM
PUSH CP,2
PUSH CP,3
PUSH CP,4
PUSH CP,FX
MOVEI FX,0
PUSH CP,SYSBFP
PUSH CP,[0]
MOVEI 1,RSTRS
CALL CLRBSS ;SAVE CURRENT TTY IN BUFFER
CLRTOB
MOVEI 1,"π" ;TYPE BELL
CALL TCO
MOVE 1,FILEN(FX)
DOBE ;WAIT TILL REALLY OUTPU
RST1P1: CALL TCI
CAIG 1,"9"
CAIGE 1,"0"
JRST RST1P2
SUBI 1,"0"
EXCH 1,RSTSUM
IMULI 1,↑D10
ADDM 1,RSTSUM
JRST RST1P1
RST1P2: CAIE 1,"," ;TERMINATE WITH COMMA?
JRST RST1P3 ;NO
HRRZ 2,-6(CP) ;YES, CHECK RET ADDR TO SEE IF CTL.P
CAIE 2,ISCTLP
JRST RST1P3 ;NO
MOVE 2,RSTSUM ;YES, GO GET A SECOND NUMBER
MOVEM 2,RTSUM2
AOS -6(CP) ;BUMP RET ADR SO WE KNOW THERE ARE 2 #'S
SETZM RSTSUM
JRST RST1P1
RST1P3: POP CP,4
MOVE 3,SYSBFP
MOVEM 1,0(CP)
CALL BKSYS2 ;RESTORE INPUT BUFFER
POP CP,1
POP CP,FX
POP CP,4
POP CP,3
POP CP,2
RET
RSTRS: IDPB 1,-3(CP)
AOS -2(CP)
RET
U RTSUM2
U RSTSUM
U IPD,NIP
IIP: IOWD NIP,IPD
U IPD1,NIP
IIP1: IOWD NIP,IPD1
;CONTROL-S - SET MINFS
RST1F: EINT
CALL RSTRN
CAIE 1,"."
JRST RSTC
MOVEI 1,MINLW
TRNN F,GCFLG ;DOING GC?
JRST RST1F1 ;NO - SET MINFS LIST
MOVE 1,GCTYP ;YES - DO FOR TYPE COLLECTING
HRRZ 1,TYPBLK(1)
ADDI 1,TMIN
RST1F1: EXCH 1,RSTSUM
CAIGE 1,↑D25 ;AT LARRY'S SUGGESTION
MOVEI 1,↑D25 ; just use min if too small
MOVEM 1,@RSTSUM
MOVEM 1,XMINARR ;IF ARRAYS MAKE MINFS PERMANENT
JRST RSTC
;INTERRUPT FOR CONTROL-T
U SINTCP
RST1T: HRRZM CP,SINTCP
EINT
CALL SAV27
TRNE F,GCFLG
JRST RST1TG
MOVEI 6,10 ; MAX # FRAMES TO EXAMINE
MOVEI 5,2 ; COUNT OF FRAMES TO BE PRINTED
; check for IO wait is simplistic, but works in most cases
MOVE 1,LPC2
MOVE 2,-1(1)
HRROI 1,[ASCIZ / RUNNING/]
CAMN 2,[BIN]
HRROI 1,[ASCIZ / IO WAIT/]
PSOUT
SKIPL NOFLG ; ONLY LOOK AT STACK IF INTERRUPTS ON
JRST RSTNO
MOVEI 5,3 ; COUNT OF FRAMES TO BE PRINTED
MOVEI 4,-1 ; WILL BE 0 IF ANYTHING PRINTED
SKIPG 3,CF ; CURRENT FRAME
JRST RSTNO ; FUNNY STATE
MOVE 2,SINTCP
CAILE 3,-FLGWD(2) ; PARTIAL FRAME?
JRST RSTNO ; YES
RST1T3: LDB 2,[POINT 11,0(3),17] ; GETNAR NOT DEFINED YET
ADD 2,0(3) ; BEG ARGS -1
HRRZ 2,1(2) ; FRAME NAME
LDT 1,2
CAIE 1,ATOMT
JRST RST1TL ; SKIP NON-ATOM
CAME 2,KPRGLM
CAMN 2,KENV
JRST RST1TL ; SKIP THESE FRAMES
CAME 2,KERSET
CAMN 2,KNIL
JRST RST1TL ; SKIP NON-ATOM OR NIL FRAME
HRROI 1,[ASCIZ / IN /]
PSOUT
HLRZ 2,2(2) ; GET PNAME
HRLI 2,440700
ILDB 4,2
ILDB 1,2
PBOUT
SOJG 4,.-2
MOVEI 6,10 ; CAN TRY SOME MORE FRAMES
SOJLE 5,RST1TO
RST1TL: HRRZ 3,2(3) ; GETCL 3,3
JUMPE 3,.+2 ; MUST BE AT TOP
SOJG 6,RST1T3 ; HAVEN'T EXCEEDED ATTEMPT COUNT
RST1TO: HRROI 1,[ASCIZ /, LOAD /]
PSOUT
MOVE 1,['SYSTAT']
SYSGT
MOVSI 1,14
HRR 1,2
GETAB
JFCL
FMPRI 1,(10.0) ; NORMALIZE LOAD 3.4 -> 34
CALL RST1TN
IFDEF MAXC,<
HRROI 1,[ASCIZ /, UTIL /]
PSOUT
MOVEI 1,-5
CPUTL
MOVE 1,2
FMPRI 1,(1000.0) ; UTIL .383 to 383
CALL RST1TN
MOVEI 1,"%"
PBOUT
>
HRROI 1,[ASCIZ /
/]
PSOUT
CALL RES27
JRST RSTC
RST1TG: HRROI 1,[ASCIZ / COLLECTING/]
PSOUT
RSTNO: HRROI 1,[ASCIZ / AT /]
PSOUT
HRRZ 2,LPC2
MOVEI 3,10
MOVEI 1,101
NOUT
JFCL
JRST RST1TO
RST1TN: FADRI 1,(0.5) ; ROUND
MULI 1,400
ASH 2,-243(1)
IDIVI 2,↑D10
MOVE 4,3
MOVEI 3,↑D10
MOVEI 1,101
NOUT
CAI 0
MOVEI 2,"."
BOUT
MOVE 2,4
NOUT
CAI 0
RET
;RUBOUT - CLEAR TTY INPUT BUFFER
RST1R: EINT
CLRTIB
RSTTCG: MOVEI 1,"π"
JRST RSTTCO
;CONTROL - O CLEAR TTY OUTPUT BUFFER
RST1O: EINT
CLRTOB
MOVEI 1,EOL
RSTTCO: CALL TCO
JRST RSTC
;CONTROL - E CALL ERROR!
RST1E: EINT
CLRTOB
MOVEI 1,EOL
CALL TCO
CALL SCLRBF
MOVEI 1,ASZ+57 ; SET ERROR NUMBER FOR WARREN
MOVE 2,KNIL
CALL SERRN
MOVEI 1,ERRORE
JRST RSTE1
;CONTROL-H - INTERRUPT AT FN CALL
RST1H: EINT
MOVEI 1,1 ;INTERRUPT ARG
URST1: MOVEM 1,UINTCH
SKIPGE NOFLG ;INTERRUPTS FORBIDDEN?
JRST .+3
SKIPE UNOFLG ;...AND USER TURNED THEM OFF?
JRST URST3 ;YES
MOVE 1,RSTBK
MOVEM 1,FNCALL ;SET TO INTERRUPT AT NEXT FN CALL
TRO F,INTFLG
CLRTOB
CALL SCLRBF ;CLEAR BUFFER AND SAVE
JRST RSTTCG
URST3: MOVEI 1,URST2 ;REMEMBER WHERE TO COME LATER
MOVEM 1,GINTD
MOVE 1,INTDO ;SET UP FOR INTERRUPTS COMMING
MOVEM 1,INTONX ;...BACK ON
JRST RSTTCG ;GO RING MY BELL
URST2: MOVE 1,RSTBK
MOVEM 1,FNCALL ;SET TO INTERRUPT AT NEXT FN CALL
TRO F,INTFLG
CLRTOB
CALL SCLRBF ;CLEAR BUFFER AND SAVE
MOVEI 1,"π" ;RING THE BELL TO SAY WE ARE ABOUT TO DO IT
CALL TCO
JRST @INTONR ;CONTINUE FROM DELAYED INTERRUPT
;CONTROL-B - INITIATE ERROR
RST1B: EINT
TRO F,ERQFLG ;REGULAR ERROR, SET FLAG
MOVEI 1,BREAKB ; DO IMMEDIATELY
RSTE1: SKIPGE NOFLG ;INTERRUPTS FORBIDDEN?
TRNE F,GCFLG ;DOING GC NOW?
JRST RSTE3 ;YES, REMEMBER REQUEST
MOVEM 1,LPC2
PUSH CP,2
SKIPE INCTLA ;WERE WE IN ↑A MODE?
CALL FIXCTA ;YES.
RSTCU: POP CP,2
JRST RSTC ;AND GO DEBREAK
RSTE3: MOVEM 1,GINTD ;SAVE ADDRESS FOR
MOVE 1,INTDO ;SET TO DO IT WHEN PERMITTED
MOVEM 1,INTONX
JRST RSTC
INTDO: JSYS INTON1
BREAKB: JSYS INTFX
JRST XBREAK
;CONTROL-D
RST1Z: EINT
CLRTOB
MOVEI 1,EOL
CALL TCO
CALL SCLRBF
RRSET: MOVEI 1,RESETD
JRST RSTE1
SRESET:
IFE TEN50,< CALL CLRBFS ;CLEAR INPUT BUFFER AND SAVE IT
>
JRST RESET
RSTBK: CALL HBREAK ;CALL TO INITIATE INTERRUPT
RSTFC: XCT 1(2) ;NORMAL FUNCTION CALL INSTRUCTION
U GINTD
;SAFE CLEAR BUFFER
SCLRBF: PUSH CP,2
PUSH CP,FX
IFE TEN50,< CALL CLRBFS>
IFN TEN50,< CALL CLRBUF>
POP CP,FX
POP CP,2
RET
; INTERRUPT HANDLERS FOR USER INTERRUPT CHARS
DEFINE DUIC(X) <IRPC X,<
RSTU'X: EINT
MOVEI 1,X
JRST RSTUN>
>
DUIC (<0123456789>)
RSTUN: PUSH CP,2
MOVE 2,UCTCT(1) ;GET CHAR ENTRY
TLNE 2,400000 ;IS CHAR REALLY ON?
JRST RSTCU ;NO - STRAY INTERRUPT - IGNORE IT
TRNE 2,400000 ;YES - IS IT A HARD OR SOFT INTERRUPT?
JRST UHARD ;HARD
SKIPE 1,UCTVAR(1) ;IS THERE AN ASSOCIATED VARIABLE?
JRST UVARD ;YES, SET IT.
HLRZ 1,2 ;SOFT - CONVERT TO LETTER
ADDI 1,100
POP CP,2
JRST URST1 ;SIMILAR TO ↑H
UHARD: HLRZ 1,2 ;HARD - CONVERT TO NUMBER
ADDI 1,ASZ ;NEED TO BOX, NOT NEEDED FOR SOFT BREAKS
MOVEM 1,UHINCH
MOVEI 1,UBREAK
POP CP,2
JRST RSTE1
UVARD: PUSH CP,3 ;SAVE ACS
PUSH CP,4
PUSH CP,5
HRRZ 2,KT ;SET THE VARIABLE TO T.
CALL SET
POP CP,5 ;RESET THE ACS
POP CP,4
POP CP,3
JRST RSTCU
U UINTCH
U UHINCH
;PERFORM CONTROL ACTION AT TIME OF FUNCTION CALL
HBREAK: LDT TP,2 ;HERE ASSUME LDT AINT A UUO
CAIN TP,LISTT
JRST .+3
CAIE TP,ATOMT
JRST @1(2) ;IGNORE LINKED CALLS ETC.
PUSH PP,2 ;FINISH HALF COMPLETED FRAME
HRRZ 3,CF
SETPPI PP,3
SETNAR 1,3
XBREAK: MOVEM 1,FNCALL ;RESET FNCALL TO NORMAL
MOVE 1,RSTFC
EXCH 1,FNCALL
BREAKE: TRZE F,ERQFLG ;TEST VARIOUS REQUEST FLAGS
BREAK: ERROR0 22,R
TRZE F,INTFLG
JRST INTR1
TLZE F,CNSFLG
JRST CNSCI
IFDEF MAXC,<
SETZM UINTCH
JRST INTR1 ; BREAK ANYWAY, SINCE THE FOLLOWING
; LOSES
>
IFNDEF MAXC,<
SOS 0(CP)
POPJ CP, ;GO RE-EXECUTE CALLING INSTRUCTION
>
U RSTCP
UBREAK: JSYS INTFX
MOVE 1,RSTFC ;HARD USER INTERRUPT
MOVEM 1,FNCALL
MOVE 1,UHINCH
ERROR1 53,R
CNSCI: PUSH CP,[3] ;INTERRUPT TYPE NUMBER
JRST INTRC
INTR1: PUSH CP,UINTCH
INTRC: PUSH PP,2 ;NAME OF FUNCTION ABOUT TO BE CALLED
MOVEI 6,-2
HRLI 6,PP
CALL LSTAR2 ;MAKE LIST OF ARGS ON STACK
PUSH PP,1 ;SECOND IS ARG LIST
POP CP,1
CALL MKN
PUSH PP,1 ;THIRD IS INT TYPE
LCALL KINT,3
RET
;ERROR MESSAGES TABLE
;REMOTE MACRO
DEFINE REMOTE (TX)
< HERE1 <TX>>
DEFINE HERE1 (NEW,OLD,%G)
< DEFINE %G
< NEW>
DEFINE REMOTE (TX)
< HERE1 <TX>,<OLD
%G
>>>
DEFINE HERE
< DEFINE HERE1 (XX,YY)
< YY>
REMOTE>
;ERROR MESSAGES
DEFINE EM (MSG,%T)
< Z %T
REMOTE <%T: SIXBIT @MSG/@
>>
ERRMT: EM <JSYS ERROR>
EM <UNDEFINED FUNCTION>
EM <STACK OVERFLOW>
EM <ILLEGAL RETURN>
EM <ARG NOT LIST> ;4
EM <UNUSED>
EM <ATTEMPT TO SET NIL OR T>
EM <ATTEMPT TO RPLAC NIL>
EM <UNDEFINED OR ILLEGAL GO> ;10
EM <FILE WON'T OPEN>
EM <NON-NUMERIC ARG>
EM <ATOM TOO LONG>
EM <ATOM HASH TABLE FULL> ;14
EM <FILE NOT OPEN>
EM <ARG NOT LITATOM>
EM <TOO MANY FILES OPEN>
EM <END OF FILE> ;20
EM <ERROR>
EM <BREAK>
EM <ILLEGAL STACK ARG>
EM <FAULT IN EVAL> ;24
EM <ARRAYS FULL>
EM <FILE SYSTEM RESOURCES EXCEEDED>
EM <FILE NOT FOUND>
EM <BAD SYSOUT FILE> ;30
EM <UNUSUAL CDR ARG LIST>
EM <HASH TABLE FULL>
EM <ILLEGAL ARG>
EM <ARG NOT ARRAY> ;34
EM <ILLEGAL OR IMPOSSIBLE BLOCK>
EM <STACK PTR HAS BEEN RELEASED>
EM <STORAGE FULL>
EM <ATTEMPT TO USE ITEM OF INCORRECT TYPE> ;40
EM <ILLEGAL DATA TYPE NUMBER>
EM <DATA TYPES FULL>
EM <ATTEMPT TO BIND NIL OR T>
EM <TOO MANY USER INTERRUPT CHARACTERS> ;44
EM <READ-MACRO CONTEXT ERROR>
EM <ILLEGAL READTABLE>
EM <ILLEGAL TERMINAL TABLE>
EM <SWAPBLOCK TOO BIG FOR BUFFER> ;50
EM <PROTECTION VIOLATION>
EM <BAD FILE NAME>
EM <USER BREAK>
EM <UNBOUND ATOM> ;54 - THESE ARE FOR WARREN
EM <UNDEFINED CAR OF FORM>
EM <UNDEFINED FUNCTION>
EM <CONTROL-E>
ERRMT1: HERE
IFNDEF MAXC,<
;SUBROUTINE TO DO RMAP'S THE TENEX WAY ON EITHER TENEX OR TOPS-20
;CALL BY RMAP1 MACRO WITH ARGS AS FOR TENEX RMAP JSYS
RMAPX: SKIPE KL20F ;ON TENEX,
JRST RMAPX1
RMAPX0: RMAP ;DO A REAL RMAP
RET
RMAPX1: RPACS ;ELSE ON TOPS-20, IF A FILE PAGE
TLZN 2,200 ;I.E. IF PRIVATE BIT OFF
JRST RMAPX0 ;STILL DO REAL RMAP. OTHERWISE,
;WE MUST FORCE IT TO BE IN A FILE, AND
;THEN RETURN THE PLACE WE PUT IT
PUSH CP,2 ;SAVE ACCESS
SKIPN TEMJFN ;FILE EXISTS?
CALL RMAPX6 ;NO, CREATE IT
EXCH 3,0(CP) ;SAVE 3, GET ACCESS OF ORIG
AND 3,[XWD 170000,0]
AOS 2,TEMPG ;MAP INTO NXT FILE PAGE
HRL 2,TEMJFN
PMAP
EXCH 1,2
PMAP ;RESTORE TO PROCESS.
POP CP,3 ;RESTORE AC3
RET
RMAPX6: PUSH CP,1 ;SAVE ORIGINAL PAGE HANDLE
MOVE 1,[XWD 610001,1] ;NEXT HIGHER VERSION, NEW FILE REQUIRED,
;TEMPORARY, VERSION NUMBER = 1
PUSH CP,1
RMAPX8: HRROI 2,[ASCIZ /LISPMF/]
GTJFN
JRST RMAPX9
HRRZM 1,TEMJFN
MOVEI 2,340000 ;READ WRITE XCT
OPENF
JRST RMAPX7
POP CP,1 ;GTJFN WORD WON'T BE NEEDED AGAIN, FLUSH
POP CP,1 ;RESTORE ORIG PAGE HANDLE TO 1
SETZM TEMPG ;INIT FREE PAGE POINTER
RET
RMAPX7: CAIE 1,OPNX9 ;INVALID SIMUL. ACCESS
JRST RMAPER ;ALL OTHERS PUNT.
HRRZ 1,TEMJFN
RLJFN
JFCL
AOS 1,0(CP) ;INCR GTJFN WORD -- TRY NXT VERSION #
JRST RMAPX8 ;PRESUMABLY ANOTHER LISP RUNNING IN THIS
;DIRECTORY
RMAPX9: CAIE 1,GJFX27 ;FILE ALREADY EXISTS (REL 3 AND LATER?)
JRST RMAPER ;ALL OTHERS PUNT
AOS 1,0(CP) ;INCR GTJFN WORD -- TRY NEXT VERSION #
JRST RMAPX8
RMAPER: HRROI 1,[ASCIZ /CANNOT OPEN LISPMF
/]
PSOUT
SETZ 3,
HRLOI 2,400000
HRRZI 1,101
ERSTR
JFCL
JFCL
HALTF
JRST .-1
>
;SET KL20 FLAG AND TRY TO GET A RELEASE NUMBER
STKL20: SETZM TEMJFN
MOVE 1,[112,,11]
CALLI 1,41
HALTF
AND 1,[100000,,770000]
CAIE 1,40000
JRST 0(7)
SETOM KL20F
MOVEI 4,1
HRLZI 1,100001
HRROI 2,[ASCIZ /<LISP>TOPS20.RELEASE/]
GTJFN
JRST STKL3
MOVE 2,[070000,,200000]
OPENF
JRST STKL4
MOVEI 3,↑D10
NIN
JRST STKL5
MOVEI 4,0(2)
STKL0: CLOSF
SKIPA
STKL1: RLJFN
JFCL
STKL2: MOVEM 4,RELNUM
JRST 0(7)
STKL3: HRROI 1,[ASCIZ /Can't find <LISP>TOPS20.RELEASE/]
PSOUT
JRST STKL2
STKL4: HRROI 1,[ASCIZ /Can't open <LISP>TOPS20.RELEASE/]
PSOUT
JRST STKL1
STKL5: MOVE 3,1
HRROI 1,[ASCIZ /Bad data in <LISP>TOPS20.RELEASE/]
PSOUT
MOVE 1,3
JRST STKL0
; RELEASENUMBER FN, RETURNS THE CURRENT RELEASE NUMBER
RLNUMB: HRROI 1,-1
SKIPE KL20F
MOVE 1,RELNUM
JRST MKN
U RELNUM
RESETE: SETOM NOFLG
SETZM UNOFLG
MOVE 1,RSTONX
MOVEM 1,INTONX
JSP 7,RESTK ;FROM INIT,START,REE, AND FN RESET
MOVE F,TFLGS
SETOM SYSCHK
SETICH
CALL SETTRP
CALL RESET1
EVQ2: SETZM ERRDSP
SETZB BR,LSTSWF
SKIPE 2,STKMOD
JRST EVQ3
EVQ6: LCALL KEVLQT ;EVALQUOTE LOOP
JRST EVQ2
EVQ3: TRNN 2,SMPR ;STACK WAS IN EMERGENCY REGION
JRST EVQ4 ;... SEE IF ITS OUT NOW
HLRZ 3,PP
CAIG 3,-NREDPP ;IF SPACE EXCEEDS EMER.
TRZ 2,SMPR ;THEN OK NOW
EVQ4: TRNN 2,SMCR ;DITTO CP
JRST EVQ5
HLRZ 3,CP
CAIG 3,-NREDCP
TRZ 2,SMCR
EVQ5: MOVEM 2,STKMOD
JRST EVQ6
RESET1: TRZ F,-1 ;CEAR TEM FLGS
TLZ F,CNSFLG
SETZM GINTD
CIS
CALL SETMOD
MOVE 1,RSTFC
MOVEM 1,FNCALL
TMSG EOLM
RET
RESTK: INTOFF
SKIPN 6,CF
JRST RESTK1
JUMPL 6,CROCK
MOVEI 3,0
JSYS SWCNTX ;UNWIND TO TOP
RESTK1: SETZM STKMOD
MOVE CP,ICP ;RESET STACKS
MOVE PP,IPP
MOVEI VP,0(PP)
PUSH CP,VP ;SET UP AN INITIAL FRAME TO RUN IN
HRRZM CP,CF
PUSH CP,[0]
PUSH CP,[0]
PUSH CP,[XWD 0,RESET]
PUSH PP,KNIL
HRLM PP,-2(CP) ;SET PPI
PUSH CP,7
JSP 7,SETSPC ;SET IPPC,ICPC
CALL STKPPG ;NULLIFY ALL STACK POINTERS
CALL FLSTKP
INTON
RET
CROCK: 0
RESETD: JSYS INTFX ;FROM ↑D
RESET: CALL RESET1 ;FROM ERRORS
HRRZ 1,KT
CALL STKGP ;FIND TOP FRAME
INTOFF
JSP 7,UNSTK
MOVEI 3,0(1)
JRST PPRC31
EVALQT: MOVEI 1,"←" ;READY CHARACTER
CALL TCO
EVQ1: LCALL KREADX,0 ;READ FUNCTION
CAMN 1,KNIL ;IGNORE NIL (UNMATCHED RT. PAREN)
JRST EVQ1
PUSH PP,1
LCALL KREADX,0 ;READ ARG LIST
PUSH PP,1
LCALL KAPPLY,2 ;EVALUATE
PUSH PP,1
LCALL KPRINT,1 ;PRINT VALUE
RET
;CLEAR ALL STACK POINTERS - IF ARG T JUST RETURN LIST OF ACTIVE ONES
CLRSTK: CAME 1,KNIL
JRST CLSTK1
CALL STKPPG
CALL CLSTKA
JRST FALSE
CLSTKA: PUSH CP,7
CLSTKB: MOVEI 1,0(3)
HRRZ 2,0(1)
STN 2,STACK
CALL RELSTK
AOBJN 3,CLSTKB
POP CP,7
RET
CLSTK1: PUSH PP,KNIL
CALL STKPPG
CALL CLSTK2
RPP: POP PP,1
RET
CLSTK2: SKIPN 2,0(3) ;RELEASED?
JRST CLSTK3
STE 2,STACK ;OR NOT TO STACK (E.G. FREE LIST)
JRST CLSTK3
MOVEI 1,0(3)
HRRZ 2,0(PP)
PUSH PP,3
CALL CONS
POP PP,3
HRRM 1,0(PP)
CLSTK3: AOBJN 3,CLSTK2
RET
U TFLGS
;MACROS FOR ACCESSING FUNCTION CALL FRAME
;FRAME FORMAT IS
; #ARGS,,PP OF BEG ARGS-1
; PPIN,,ALINK (PPIN IS BEG TEMS -1)
; USE,,CLINK
; CPOUT,,PPR
; ..
; ..
; PPOUT,,REAL RETURN (PPOUT EXCLUDES ARGS OF CALLED FN)
; BASIC FRAME ON PP CONTAINS ARGS FOLLOWED BY CXT,,FN NAME
;PPOUT AND CPOUT ARE ONLY VALID WHEN FRAME IS NOT ACTIVE
CPOWD==3
FLGWD==3
CLWD==2
USEWD==2
PPIWD==1
BASWD==0
NARWD==0
NARSIZ==11 ;BYTE SIZE FOR # ARGS - USE SO CAN FIND ALL REFS
NARM1==777000 ;MASK FOR NON-ARG PART OF HALF-WORD
SWPBIB==400000 ;SWAPPED BASIC FRAME INACTIVE BIT
SHLBIT==-1-AVBLIP ; MASK FOR TESTING IF AN ARG IS LOCAL OR SHALLOW
SWPEIB==200000 ;SWAPPED EXTENSION INACTIVE BIT
FGCBIT==100000 ;GC MARK BIT IN FIRST WD OF FRAME
FGCWD==0
STKX==30 ;EXTRA SPACE REQUIRED TO RUN A FRAME
; EIB IS EXTENSION INACTIVE BIT, 1=>EXT INACTIVE,
; 0 => IN ACTIVE ACCESS CHAIN
; BIB IS BASIC FRAME INACTIVE BIT, 1=> BASIC FRAME INACTIVE AND
; THEREFORE DEEP BOUND (SPECVARS ARE CURRENT VALUES),
; 0=> BASIC FRAME IS ACTIVE, THEREFORE SHALLOW BOUND
; (SPECVARS ARE "OLD" VALUES).
;NOTE THAT THE BASIC FRAME MAY BE MARKED ACTIVE EVEN IF ARGS
;NOT SHALLOW BOUND YET AS LONG AS NO JUNK IN LEFT HALVES.
;ALSO IT IS POSSIBLE FOR A FRAME EXTENSION TO BE INACTIVE
;WHILE ITS BASIC FRAME IS ACTIVE (BECAUSE THE BASIC FRAME
;IS SHARED WITH THE ACTIVE ACCESS CHAIN).
DEFINE GETNAR (A,B)
< LDB A,[POINT NARSIZ,0(B),17]>
DEFINE GETBAS (A,B)
< HRRZ A,0(B)>
DEFINE GETEIB (A,B)
< LDB A,[POINT 1,0(B),1]>
DEFINE GETBIB (A,B)
< GETNAR A,B
ADD A,BASWD(B)
LDB A,[POINT 1,1(A),0]>
DEFINE GETCPO (A,B)
< HLRZ A,3(B)>
DEFINE GETAL (A,B)
< HRRZ A,1(B)>
DEFINE GETPPI (A,B)
< HLRZ A,1(B)>
DEFINE GETCL (A,B)
< HRRZ A,2(B)>
DEFINE GETUSE (A,B)
< HLRE A,2(B)>
DEFINE GETFLG (A,B)
< HRRZ A,3(B)>
DEFINE GETPPO (A,B)
< GETCPO A,B
HLRZ A,0(A)>
DEFINE GETFGC (A,B)
< HLRZ A,FGCWD(B)>
DEFINE SETNAR (A,B)
< DPB A,[POINT NARSIZ,0(B),17]>
DEFINE SETBAS (A,B)
< HRRM A,0(B)>
DEFINE SETEIB (A,B)
< DPB A,[POINT 1,0(B),1]>
DEFINE SETBIB (A,B)
< GETNAR TP,B
ADD TP,BASWD(B)
DPB A,[POINT 1,1(TP),0]>
DEFINE SETCPO (A,B)
< HRLM A,3(B)>
DEFINE SETAL (A,B)
< HRRM A,1(B)>
DEFINE SETPPI (A,B)
< HRLM A,1(B)>
DEFINE SETCL (A,B)
< HRRM A,2(B)>
DEFINE SETUSE (A,B)
< HRLM A,2(B)>
DEFINE SETFLG (A,B)
< HRRM A,3(B)>
DEFINE SETFGC (A,B)
< HRLM A,FGCWD(B)>
;FUNCTION CALL UUO FOR CALLS FROM COMPILED CODE
;AND FUNCTION CALLER FOR INTERPRETER
FNACAL: PUSH PP,1 ;"PUSH AC1 FIRST" ENTRY
FNCALQ: LDB 1,UUACP
HRRZ 2,@40 ;FN NAME
EFNCAL: MOVEI VP,0(PP) ;ENTRY WITH # ARGS IN 1,NAME IN 2
SUBI VP,0(1) ;SET RESET PP TO UNCOVER ARGS
HRLM VP,0(CP) ;SAVE RESET PP IN CALLERS FRAME
IFNDEF MAXC,<
MOVEI 3,1(CP) ;NEW CF MUST BE SET BEF. NEXT PUSH
EXCH 3,CF ;IN CASE OVERFLOW
SETCPO CP,3 ;RESET CP TO CALLERS FRAME
PUSH CP,VP ;PTR TO FIRST ARG-1
PUSH CP,3 ;SET ALINK
PUSH CP,3 ;= CLINK
XFNCA: XCT FNCALL ;GO TO FN ENTRY
PPR: ;SIMPLE RETURN
MOVE 2,@CF
HLRZ 4,2 ;GET ARG COUNT
ADDI 2,1(4)
JRST PPR3
PPR1: MOVS 3,0(2)
TRNE 3,SHLBIT
HLRM 3,0(3)
PPR3: SOS 2 ;POINT TO NEXT ARG
SOJGE 4,PPR1 ;DEC ARG COUNT
PPR2: POP CP,3 ;CLINK(=ALINK)
SUB CP,BHC+2 ;FLUSH REST OF FRAME
GETUSE 4,3 ;USE(CALLER)
HLRZ PP,0(CP) ;GETPPO(CALLER) TO RESET PP
HRLI PP,@IPPC ;FIX LEFT
SOJL 4,PPRA ;USE(CALLER) gt 0?
SETUSE 4,3 ;DECREM USE(CALLER)
JSP 7,ECOP ;COPY CALLERS EXT.
>;IFNDEF MAXC
IFDEF MAXC,<
XFNCA: CALLFN 3,FNCALL
PPR: RETFR 3,0(CP)
MOVEM 7,PPRCS7
JSP 7,ECOP
MOVE 7,PPRCS7
>;IFDEF MAXC
PPRA: HRRZM 3,CF ;RESET CURRENT FRAME
HRRZ VP,0(3) ;SET UP ARG PTR
R: POPJ CP, ;AND REALLY RETURN
HCRET: XWD 0,PPR
IFNDEF MAXC,<
; on Maxc, CF is fixed location (200) so CALLFN can find it
U CF ;CONTAINS CURRENT FRAME ALWAYS
>
U OPP ;SAVED PP WHEN CURRENT FRAME INVALID
;REWIND A BASIC FRAME GIVEN -NARGS-1,,FIRST-1 IN 2
;CLOBBER 3 AND 4
;INTERRUPTS SHOULD BE OFF
REWB: MOVS 3,0(2) ;GET PRIOR VALUE,,VPTR OR CURR,,VPTR
TRNN 3,SHLBIT
JRST REWIND ;LOCAL VAR
HRRZ 4,0(3) ;CONTENTS VCELL
HRRM 4,0(2) ;TO FRAME
HLRM 3,0(3) ;AND OLD CONTENTS FRAME TO VCELL
REWIND: AOBJN 2,REWB
MOVSI 3,SWPBIB
XORM 3,0(2) ;COMPLEMENT THE BIT
JRST 0(7)
;UNWIND A BASIC FRAME GIVEN NARGS,,FIRST-1 IN 2
;CLOBBER 3 AND 4
;INTERRUPTS SHOULD BE OFF
UNWIND: HLRZ 3,2 ;MAKE INTO NARGS,,LAST+1
ADDI 2,1(3)
MOVSI 3,SWPBIB
XORM 3,0(2) ;COMPLEMENT THE BIT
UNWB: SUB 2,[1,,1]
JUMPL 2,0(7)
MOVS 3,0(2) ;GET PRIOR VALUE,,VPTR OR CURR,,VPTR
TRNN 3,SHLBIT
JRST UNWB ;LOCAL VAR
HRRZ 4,0(3) ;CONTENTS VCELL
HRRM 4,0(2) ;TO FRAME
HLRM 3,0(3) ;AND OLD CONTENTS FRAME TO VCELL
JRST UNWB
;MAKE A FRAME FOR COMPILED PROG AND LAMBDA AND RETFN IN BLOCK
;CALLED JSP 5,CFRAM WITH #ARGS IN 1, FN NAME IN 4, CALLERS ADDR IN 7
;PRESERVE AC'S 6 AND 7
CFRAM: MOVEI 2,CFRAM1 ;DUMMY ATOM
CFRAM1: JRST EFNCAL ;RET IS ALREADY STACKED
PUSHJ CP,.+1 ;XCT'D
HRLM 1,-3(CP)
PUSH PP,4 ;FN NAME
HRLM PP,-2(CP) ;SET PPI
JUMPE BR, 0(5) ; BR=0 means not swapped
CAME 3,LSTSWF ;SWAPPED?
JRST 0(5) ;NO
PUSH CP,BR
MOVSM BR,0(CP)
MOVE 3,CF
MOVEM 3,LSTSWF
CALL 0(5)
SWPRT2: SUB CP,BHC+1 ;GET RID OF JUCK
HRRZ 2,-1(CP) ;CLINK OF CF
MOVEM 2,LSTSWF
RET
;ENTRY SEQUENCE FOR HAND CODED FUNCTIONS
;#ARGS GIVEN 1N 1,NAME IN 2,
HCAL1Q: ;SPREAD EVAL,AND NO-EVAL ARE SAME
HCAL0Q: LDB 3,UUACP ;GET # ARGS NEEDED
HCSET2: SUBI 1,0(3) ;DIFFERENCE BET. # GIVEN AND NEEDED
JUMPLE 1,HCSET4(1) ;OK OR TOO FEW
SUB PP,BHC(1) ;TOO MANY FLUSH EXTRA
JRST HCSET4
PUSH PP,KNIL ;PUSH EXTRA ARGS - MAX 6
PUSH PP,KNIL
PUSH PP,KNIL
PUSH PP,KNIL
PUSH PP,KNIL
PUSH PP,KNIL
HCSET4: HRLM 3,-3(CP) ;NUMBER ARGS STACKED
PUSH PP,2 ;STORE NAME FOLLOWING ARGS
HRLM PP,-2(CP) ;SAVE PPIN
HRRZ 1,1(VP) ;ARGS TO 1-3
HRRZ 2,2(VP)
HRRZ 3,3(VP)
JRST @40
;EVAL - NO-SPREAD
HCAL2Q: HRLM 1,-3(CP)
HCSET3: PUSH PP,2 ;STORE NAME
HRLM PP,-2(CP) ;SAVE PPIN
HRRZ VP,-3(CP)
JRST @40
;NO-EVAL, NO-SPREAD
HCAL3Q: HRLM 1,-3(CP) ;STORE # ARGS (1)
HRRZ 1,1(VP) ;GET ARG TO 1
JRST HCSET3
;HARDER RETURN, ALINK NOT EQ CLINK, OR CXT>0
;OR NOT RETURNING TO FRAME ABOVE, OR TEMS AND ARGS
;NOT CONTIGUOUS
PUSH CP,3 ;IMAGE OF EFNCAL - C-STACK OVF
PUSH CP,3 ;...RESUMES HERE
XFNCC: XCT FNCALL
PPRC: INTOFF
IFDEF MAXC,<MOVEM 7,PPRCS7> ; save 7
POP CP,3 ;GET CLINK
POP CP,6 ;AND ALINK
POP CP,2 ;AND PTR TO ARGS-1 - NOW EXT. IS GONE
HLRZ PP,6 ;GET PPI FROM ALINK WD,FLUSH TEMS(RETURNER)
TLZ 2,NARM1 ;AND SET UP TO UNBIND ARGS
HLRZ 4,2
ADDI 4,1(2) ;ADDR OF CXT WD
HLRZ 5,0(4) ;CXT(RETURNER)
SOJGE 5,PPRC1 ;DECREM
HRRI 2,0(4) ;CXT=0
JRST PPRC2B
PPRC2A: MOVS 5,0(2) ; FLUSH BASIC FRAME -SIMPLE UNBIND
TRNE 5,SHLBIT ;SHALLOW?
HLRM 5,0(5) ;YES - VALUE TO VCELL
PPRC2B: SUB 2,[1,,1] ;DEC ARG CNT AND POINT TO NEXT VAR
JUMPGE 2,PPRC2A
CAIE 4,0(PP) ;IS BASIC FR. CONTIGUOUS WITH TEMS?
JRST PPRC2 ;NOPE
MOVEI PP,0(VP) ;ARGS ARE IN ACTIVE PP
PPRC3: HRLI PP,@IPPC ;FIX LEFT PP
CAIN 3,0(6) ;ALINK=CLINK?
JRST PPRC31 ;YES
MOVEM CP,CF ;IN CASE FLFR CAUSES C-STACK OVF
JSYS SWCNTX ;SWITCH CONTEXT
MOVEI 2,0(6)
CALL FLFR ;FLUSH ALINK FRAME
JRST PPRC31
PPRCR: INTOFF ;ENTER HERE TO JUST RUN A FRAME
PPRC31: GETUSE 4,3 ;USE(CALLER)
SOJGE 4,PPRCB ;>0 ?
GETCPO 4,3 ;IS 0 , CAN RUN
CAIE 4,0(CP) ;IS CP CONTIGUOUS
JSYS RECP ;NO FIDDLE CP
PPRC7: HLRZ 4,0(CP) ;GET RESET PP
CAIE 4,0(PP) ;IS THAT CONTIGUOUS
JSYS REPP ;PP NOT CONTIG - FIX IT
TLNE PP,-1 ;ANY SPACE?
JRST PPRC41 ;OK - GO RUN
PPRPPO: HRRZM 3,CF ;NO ROOM TO RUN IN PP
JSP 7,ECOPPO
JRST PPFUL ;REALLY FULL
JRST PPRC41
PPRC2: SUBI 4,0(VP) ;FLUSH BASIC FRAME OF RETURNER
HRLI 4,STKHOL ;MARK BASIC FRAME AS HOLE
MOVEM 4,1(VP)
JRST PPRC3
PPRCB: SETUSE 4,3 ;NEW USE(CALLER)
PPRCD: JSP 7,ECOP ;COPY FRAME EXT.
PPRC41: HRRZM 3,CF
HLRE 4,CP ;CHECK FOR ROOM TO RUN
MOVN 4,4
CAILE 4,STKX
JRST PPRC42
JSP 7,ECOPCO
JRST CPFUL
PPRC42: INTON
IFDEF MAXC,<MOVE 7,PPRCS7>
HRRZ VP,0(3)
POPJ CP,
PPRC1: HRLM 5,0(4) ;CXT(RETURNER)>0 DECREM.
HRLI PP,@IPPC
MOVEI 5,0(3) ;PRESERVE 3
IFDEF MAXC,<UNWND>
IFNDEF MAXC,<
JSP 7,UNWIND ;UNBIND RETURNER'S FRAME
>
MOVEI 3,0(5)
CAIE 3,(6) ;ALINK=CLINK?
JSYS SWCNTX
JRST PPRCD ;GO COPY CALLER W/O DECREM. USE
PPRCP: POINT NARSIZ,2,17
;NFRESZ==8
;PPRFP: POINT NFRESZ,2,8
;SET UP NEW CP AND ICPC, ABANDONS CURRENT STACK
;NEW CP IN 4, PRESERVES AC'S 1,2,3
;TERMINAL INTERRUPTS SHOULD BE OFF
RECP: XWD RECPX,.+1
HLRE 5,CP
JUMPE 5,PPRC5
MOVN 5,5 ;ABANDON CURRENT STACK
HRLI 5,STKHOL
MOVEM 5,1(CP) ;MARK A HOLE
PPRC5: MOVEI CP,0(4)
SETZ 5,
JSYS MRGHOL ;LLOK FOR HOL AFTER NEW CP
ADDI 5,0(CP)
MOVN 5,5
HRLI 5,CP
MOVEM 5,ICPC
HRLI CP,@5 ;ADJUST LEFT
JRST @RECPX
;NOTE - WE MUST CLEAR ALL EXTRANEOUS HOLE MARKS ON PP BECAUSE
;IF WE RETURN TO A FRAME, E.G. VIA RETTO, THAT HAS NO PTEMS-
;THEN PPI/PPO MAY BE POINTING INTO THE MIDDLE OF A HOLE - AND
;WE MUST NOT RUN THERE.
REPP: XWD RECPX,.+1
HLRE 5,PP ;PP NOT CONTIQUOUS
JUMPE 5,PPRC8
MOVN 5,5 ;MARK CURRENT STACK AS HOLE
HRLI 5,STKHOL
MOVEM 5,1(PP)
PPRC8: MOVEI PP,0(4) ;SET PP TO PPO OF NEW FR.,0 LEN.
SETZ 5,
JSYS MRGHOL ;DOES HOLE FOLLOW
SKIPE 5
SETZM 1(4) ;CLEAR HOLE MARK WHERE ABOUT TO RUN
ADDI 5,0(PP)
MOVN 5,5
HRLI 5,PP
MOVEM 5,IPPC
HRLI PP,@5 ;ADJUST LEFT
JRST @RECPX
U RECPX
IFDEF MAXC,<U PPRCS7>
;COPY CP PART OF FRAME EXTENSION
;CALL WITH BEGINNING IN 3, END IN 2, # SLOTS REMAINING ON CP IN 5
;AND CP TRUE
;RETURN WITH OLD BEGINNING STILL IN 3, PRESERVE AC1 AC7,
;OLD LENGTH IN PPT, NEW BEGINNING IN 4
;CP AND ICPC UPDATED, OLD CP HOLE MARKED. SKIP IF OK
;TERMINAL INTERRUPTS S/B OFF
CPCOP: XWD CCOPX,.+1 ;LOOK FOR A PLACE TO PUT IT
MOVEI 4,0(CP) ;LOOK AFTER CURRENT CP FIRST
JSYS MRGHOL
SUBI 2,-1(3) ;# NEEDED
MOVEM 2,PPT ;SAVE LENGTH NEEDED
CAIG 5,STKX(2) ;HOLE BIG ENUF?
JRST CPCOP1 ;NOPE
CPCOP4: MOVEI 6,1(4) ;USE HOLE, 4 IS BEG-1
HRLI 4,2
HRLI 6,0(3)
SKIPE 2
BLT 6,@4
MOVEI CP,@4 ;RESET CP TO NEW END
SUB 2,5 ;- UNUSED LEN HOLE
HRLM 2,CP
SUBI 2,0(CP)
HRLI 2,CP
MOVEM 2,ICPC
JRST CPCOPO
CPCOP1: HRRZ 4,ICP
CPCOP3: CAIN 3,1(4) ;SKIP THE ONE WE ARE TRYING TO COPY
ADD 4,PPT ;... CPO MAY BE WRONG
HLRZ 5,1(4)
CAIN 5,STKHOL ;HOLE FOLLOWS?
JRST CPCOP2
CAIN 5,STKEND ;OR END OF BLOCK?
JRST CPCOP7
HLRZ 4,CPOWD+1(4) ;NO - CPO IS NEXT END
JRST CPCOP3
CPCOP2: HRRZ 5,1(4) ;HOL LENGTH
JSYS MRGHOL
CAILE 5,STKX(2) ;BIG ENUF?
JRST CPCOP4 ;YES - USE IT
ADDI 4,0(5) ;NO - TRY AGAIN
JRST CPCOP3
CPCOP7: HRRZ 4,1(4) ;NEXT STACK REGION
JUMPE 4,@CCOPX ;NO MORE STACK AT ALL
CAME 4,IREDCP ;LAST STACK REGION?
JRST CPCOP3 ;NO - JUST GO ON
MOVE 5,STKMOD ;YES
TROE 5,SMCR ;ALREADY IN EMER. MODE?
JRST CPCOP3 ;YEP - JUST GO ON
MOVEM 5,STKMOD ;NOPE - SET RED
JSP 6,PPCOPB ;AND SET TO BREAK WHEN INTS GO ON
JRST CPCOP3
;COPY PP PART OF AN EXTENSION
;SPECS DITTO TO CPCOP
PPCOP: XWD CCOPX,.+1
MOVEI 4,0(PP)
JSYS MRGHOL
SUBI 2,-1(3)
MOVEM 2,PPT ;SAVE LENGTH NEEDED
CAIG 5,0(2)
JRST PPCOP1
PPCOP4: HRRZ 2,PPT ;LENGTH
MOVEI 6,1(4)
SETZM 1(4) ;CLEAR HOLE MARK WHERE ABOUT TO RUN
HRLI 4,2
HRLI 6,0(3)
SKIPE 2 ;MAY BE NOTHING TO COPY
BLT 6,@4
MOVEI PP,@4
SUB 2,5
HRLM 2,PP
SUBI 2,0(PP)
HRLI 2,PP
MOVEM 2,IPPC
CPCOPO: MOVEI 4,1(4) ;NEW BEGIN
AOS CCOPX ;SKIP IF OK
JRST @ CCOPX
PPCOP1: HRRZ 4,IPP
PPCOP3: CAIN 3,1(4) ;SKIP THE ONE WE ARE TRYING TO COPY
ADD 4,PPT
HLRZ 5,1(4)
CAIN 5,STKHOL ;HOLE?
JRST PPCOP2
CAIN 5,STKEND ;OR END?
JRST PPCOP7 ;YES
AOJA 4,PPCOP3
PPCOP2: HRRZ 5,1(4) ;HOLE LENGTH
JSYS MRGHOL
CAMLE 5,PPT
JRST PPCOP4 ;THIS HOLE WILL DO
ADDI 4,0(5)
JRST PPCOP3
PPCOP7: HRRZ 4,1(4) ;NEXT STACK REGION
JUMPE 4,@CCOPX ;NO MORE STACK AT ALL
CAME 4,IREDPP ;LAST STACK REGION?
JRST PPCOP3 ;NO - JUST GO ON
MOVE 5,STKMOD
TROE 5,SMPR ;STK ALREADY IN EMERG. REGION?
JRST PPCOP3 ;YES - JUST GO ON AND LET IT DIE
MOVEM 5,STKMOD ;SET MODE TO RED
JSP 6,PPCOPB
JRST PPCOP3
PPCOPB: MOVEI 5,PDLBRK
SKIPGE NOFLG ;TERM INTS OFF BY SOFTWARE?
JRST PPCOP8 ;NO - MUST BE PROCESSING A TRAP
MOVEM 5,GINTD
MOVE 5,INTDO
MOVEM 5,INTONX ;SET TO BREAK WHEN INTS GO ON
JRST 0(6)
PPCOP8: MOVEM 5,LPC1 ;DEBRK TO A PDLERR
JRST 0(6)
U PPT
U CCOPX
;MERGE STACK HOLES
;5 HAS # OF EMPTIES SO FAR(FROM CURRENT CP OR FIRST HOL FOUND)
;4 HAS CURRENT POS -1
;RETURN W / MERGED LENGTH IN 5
;AND UPDATED MARKER IN FIRST HOLE
;PRESERVE ALL OTHER AC'S BUT 6
MRGHOL: XWD MRGHX,.+1
HRLI 4,5
MRGH2: MOVEI 6,@4
CAIE 6,0(PP)
CAIN 6,0(CP)
JUMPN 5,MRGH1 ;DONT WALK ON CURRENT STACKS
MOVE 6,1(6) ;LOOK AT END +1
TLC 6,STKHOL
TLNE 6,-1 ;HOLE?
JRST MRGH1 ;NO
ADDI 5,1
SETZM @4 ;CLEAR EXTRANEOUS HOL MARK
ADDI 5,-1(6)
JRST MRGH2
MRGH1: JUMPE 5,MRGH3 ;QUIT IF NO HOLE AT ALL
MOVEI 6,0(5) ;MARK HOLE BEGINNING
HRLI 6,STKHOL
MOVEM 6,1(4)
MRGH3: MOVEI 4,0(4) ;CLEAR LEFT
JRST @MRGHX
U MRGHX
;COPY FRAME EXTENSION BECAUSE USE WAS > 0
;CALL WITH JSP 7, ; BEG FRAME IN 3, CPO OF FRAME IS OK
;RETURN WITH NEW BEG IN 3, PRESERVE AC1
;UPDATE CF, CP, PP, ICPC, IPPC
ECOP: INTOFF
MOVEI 5,1
SETEIB 5,3 ;MARK ORIG EXT INACTIVE
MOVEI 5,PPRC ;SET HARD RET IN BOTH ORIG AND COPY
SETFLG 5,3
HLRE 5,CP ;# LOCS LEFT ON CURRENT CP
MOVN 5,5
GETCPO 2,3 ;END OF FRAME
JSYS CPCOP ;COPY CP PART
JRST CPFUL ;NO SPACE
JUMPE BR,ECOP2 ;IS THERE AN ACTIVE SWAPPED GUY?
CAME 3,LSTSWF ;YES, IS HE THE ONE BEING COPIED?
JRST ECOP2
MOVEM 4,LSTSWF ; MAKE THE COPY BE THE CURRENT GUY
GETCPO TP,3 ;FIX UP THE ORIGINAL
HRRZ 5,0(TP) ;DONT CALL SWPFIX BECAUSE IT CLOBBERS BR
CAIN 5,BRREST ;AND FRAME MAY ALREADY BE FIXED
JRST ECOP2
HRLM 5,5(3) ;REAL RET TO SWPRET WD
MOVEI 5,BRREST ;AND BRREST TO REAL RET
HRRM 5,0(TP)
ECOP2: HRRZS USEWD(4) ;USE OF COPY = 0
MOVEI 5,0
SETEIB 5,4 ;MARK NEW COPY ACTIVE
HRRZM 4,CF ;RESET CF
ECOP1: HLRE 5,PP
MOVN 5,5
GETNAR 2,4
ADD 2,0(4) ;PTR TO LAST ARG
MOVSI 3,1
ADDM 3,1(2) ;INCREMENT CXT
GETPPI 3,4
ADDI 3,1 ;TEMS BEGIN AT PPI +1
GETPPO 2,4 ;END TEMS
JSYS PPCOP
JRST PPFUL ;REALLY FULL
HRRZ 3,CF
SUBI 4,1
SETPPI 4,3 ;RESET PPI
INTON
JRST 0(7)
;COPY CP PART OF EXTENSION BECAUSE OF EVERFLOW OR NO
;ROOM TO RUN, CF IS CURRENT FRAME (I.E. BEG)
;AND CURRENT CP IS END; RET NEW POS IN 3,AND
;UPDATE CF IF PERTINENT, CP AND ICPC UPDATED, SKIPS IF OK
;TERMINAL INTERRUPTS MUST BE OFF
ECOPCO: SKIPG 3,CF
MOVEI 3,1(3) ;NEG MEANS NOT REAL FR.(AND ONE LESS)
HLRE 5,CP ;NUM SLOTS REMAINING ON CP
MOVN 5,5
MOVEI 4,0(CP) ;LOOK FOR HOLE AFTER
MOVEI 2,0(5) ;REMEMBER OLD # SLOTS LEFT
ADDI 4,0(5)
ECPO4: MOVE 6,1(4)
TLC 6,STKHOL
TLNE 6,-1
JRST ECPO5
ADDI 5,0(6)
ADDI 4,0(6)
JRST ECPO4
ECPO5: CAIG 5,0(2) ;WAS THERE A HOLE?
JRST ECPO6 ;NOPE
MOVN 5,5 ;IF SO JUST UPDATE CP
HRLI CP,0(5)
ADDI 5,0(2)
ADDM 5,ICPC ;AND ICPC
HRLI 5,0(5)
SKIPG CF
ADDM 5,CF ;AND ALSO LEFT CF IF PERTINENT
JRST 1(7)
ECPO6: MOVEI 2,0(CP)
JSYS CPCOP
JRST 0(7) ;FULL - NO SKIP
HRRZ 5,PPT ;LENGTH
HRLI 5,STKHOL ;MARK ORIG. AS HOLE
MOVEM 5,0(3)
MOVEI 3,0(4) ;NEW BEG.
JUMPE BR,ECPO3
MOVE 4,LSTSWF
CAMN 4,CF
HRRM 3,LSTSWF
ECPO3: HRRM 3,CF
SKIPG CF
JRST ECPO2
CAILE 3,-FLGWD(CP)
JRST 1(7) ;PARTIAL FRAME
ECPO1: GETFLG 4,3
MOVEI 5,PPRC
CAIN 4,PPR
SETFLG 5,3 ;RESET PPR TO PPRC
JRST 1(7)
ECPO2: MOVEI 5,-1(3)
ADD 5,ICPC ;KEEP LEFT CF UPDATED FOR ICPFUL
HRLI 5,0(5) ;AND BECAUSE IT SEEMS A GOOD IDEA
HRRI 5,-1(3)
MOVEM 5,CF
JRST 1(7) ;WASNT REAL FRAME
;COPY PP PART OF AN EXTENSION BECAUSE OF PP OVF OR NO ROOM TO RUN
ECOPPO: SKIPG 3,CF
SKIPA 4,OPP ;NOT REAL FRAME - GET PP FROM OPP
GETPPI 4,3 ;PTR TO FRST TEM -1
SKIPN 4
GETBAS 4,3 ;PPI=0 MEANS PARTIAL FRAME
MOVEI 3,1(4)
MOVEI 2,0(PP)
SETZ 5,
JSYS PPCOP
JRST 0(7) ;FULL - NOSKIP
HRRZ 5,PPT ;MARK ORIG AS HOLE
JUMPE 5,EPPO2 ;IF IT EXISTED
HRLI 5,STKHOL
MOVEM 5,0(3)
EPPO2: SKIPG 3,CF ;REAL FRAME?
JRST EPPO3 ;NO -
SUBI 4,1 ;YES - UPDATE PPI
GETPPI 2,3
JUMPE 2,EPPO1 ;IF IT WAS PERTINENT
SETPPI 4,3
JRST ECPO1
EPPO1: SETBAS 4,3 ;PPI 0 MEANS HALF COMPLETED FN CALL
HRRI VP,0(4) ;SO KEEP VP TRUE
JRST ECPO1 ;..SO COPY FROM BEG ARGS AND UPDATE
EPPO3: HRRM 4,OPP ;NOT REAL FRAME - KEEP OPP
SOS OPP ;UP TO DATE
JRST 1(7)
;FLFR RELEASES FRAME - FRAME IN 2
;CLOBBERS 4,5,6
;ALSO NEEDS CONTROL STACK BUT NO P-STACK
;RET WITH LAST FRAME FLUSHED FROM C CHAIN IN 2
;RELSTK(POS) - NULLIFY STK PTR AND RELEASE STORAGE - PRESERVE AC1,3
RELSTK: STE 1,STKP
RET ;NOT STK PTR - IGNORE
MOVEI 2,0
INTOFF
EXCH 2,0(1) ;SET CONTENTS TO 0
JRST FLFRZ
FLFR: INTOFF
FLFRZ: CALL FLFRA
INTON
RET
FLFRA: STE 2,STACK
RET ;CONTENTS ALREADY DEAD
GETUSE 5,2
SOJL 5,FLFR1
SETUSE 5,2 ;USE > 0
POPJ CP, ;DECREMENT AND QUIT
FLFR1: GETNAR 5,2
ADD 5,0(2) ;GET CXT
HLRZ 4,1(5)
TRZ 4,SWPBIB ;COULD BE DEEP BOUND
HLRZ 6,1(5)
ANDI 6,SWPBIB
SOJL 4,FLFR2
IORI 4,(6) ;PUT BACK DEEP BIT
HRLM 4,1(5) ;CXT>0, DECREMENT
JRST FLEXT ;AND GO FLUSH EXTENSION
FLFR2: PUSH CP,0(2) ;USE=0,CXT=0 - FLUSH EVERYTHING
CALL FLEXT ;FLUSH EXTEN. FIRST (HOLES MAY MERGE)
POP CP,4 ;BEG ARGS -1
LDB 5,[POINT NARSIZ,4,17]
; LDB 6,[POINT NFRESZ,4,8] ;# FREE VARS
; ADDI 5,1(6) ;#ARGS+#FREE+1 IS BASIC FR. SIZE
ADDI 5,1 ;NOW BASIC FRAME SIZE IS # ARGS+1
JSYS MRGHOL ;FLUSH BASIC FRAME
GETAL 5,2
GETCL 2,2 ;CHEAT! LINKS STILL THERE AFTER FLUSH
CAIN 2,0(5) ;CLINK=ALINK?
JRST FLFRA ;YES - GO ROUND AGAIN
HRLM 2,0(CP)
MOVEI 2,0(5)
CALL FLFRA ;NO - FLUSH A CHAIN TOO
HLRZ 2,0(CP) ;THEN DO C
JRST FLFRA
FLEXT: GETPPO 5,2
GETPPI 4,2
SKIPN 4
GETBAS 4,2
SUBI 5,0(4)
SKIPE 5
JSYS MRGHOL ;MARK TEMS DELETED
GETCPO 5,2 ;NOTE - ONLY WORKS FOR STATIC FRAMES!
SUBI 5,-1(2)
MOVEI 4,-1(2)
JSYS MRGHOL ;MARK CP PART DELETED
RET
;LINKED FUNCTION CALL UUO
;LNCALL #ARGS,P
;P: HCCALBITS,,DEF
;P+1: NAME,,HCCALQ OR EXCALQ OR CCALC
ALCALQ: PUSH PP,1 ;ENTRY TO PUSH AC1 FIRST
LCALQ: LDB 1,UUACP
LCALQ2: MOVEI 2,.+1 ;MAKE FRAME
JRST EFNCAL
PUSHJ CP,.+1 ;XCT'D
MOVE 2,@40
EXCH 2,40 ;DEF TO 40
MOVE 3,1(2)
HLRZ 2,3 ;FN-NAME
JRST 0(3)
CCALC: JRST @40
;ENTRY SEQUENCE FOR EXPR'S
LAMCAL: POP PP,2 ;CALL OPEN LAM - GET EXPR
SUBI 1,1 ;DECR. # ARGS NOW
SKIPA 3,2
EXCALQ: HRRZ 3,40
CAMN 3,KNIL
JRST EXILL
CARA 5,3
CAME 5,KLAM
CAMN 5,KNLA
JRST EXCLM
EXILL: PUSH PP,2 ;FN NAME
HRRZ 3,CF ;FINISH FRAME
SETNAR 1,3
SETPPI PP,3
PUSH PP,2
MOVEI 6,-2
HRLI 6,PP
CALL LSTAR2
PUSH PP,1
LCALL KFALTA,2
RET
EXCLM: CDRA 3,3
CARA 4,3 ;VARIABLE LIST
INTOFF ;MUST BE OFF 'CAUSE #ARGS MIGHT CHANGE
CAMN 4,KNIL
JRST EXCLM3
STN 4,LIST ;LIST OR NIL?
JRST EXCLM6 ;YES
STE 4,ATOM ;MAKE SURE VAR IS LITATOM
JRST EXER1
CAMN 4,KT ;AND NOT T
JRST EXER3
CAME 5,KNLA ;NO, LAMBDA OR NLAMBDA?
JRST EXCLM4
CAIGE 1,1 ;NLAMBDA - BIND TO ARG
PUSH PP,KNIL ;OR NIL IF NO ARG GIVEN
JRST EXCLM5
EXCLM4: ADDI 1,ASZ ;LAMBDA- BIND TO NUMBER OF ARGS
PUSH PP,1
EXCLM5: PUTNAM 4,0(PP)
EXCLM3: PUSH PP,2 ;SAVE NAME
MOVEI 1,0(PP)
SUBI 1,1(VP) ;COMPUTE # ARGS STACKED
HRLM 1,-3(CP) ;SAVE # ARGS
INTON ;INT'S BACK ON
HRLM PP,-2(CP) ;SAVE PPIN
CDRA 1,3 ;FORM TO BE EVALED
JRST PROGN ;GO EVAL FORMS
EXCLM6: HRRZ 6,-3(CP)
EXCLM2: CAMN 4,KNIL ;FINISHED BINDINGS?
JRST EXCLM3 ;YES
CARA 5,4
CDRA 4,4
STE 5,ATOM ;MAKE SURE VAR IS LITATOM
JRST EXER2
CAME 5,KNIL ;AND NOT NIL
CAMN 5,KT ;OR T
JRST EXER4
SKIPG 1
JRST EXCLM7
PUTNAM 5,1(6) ;;BIND THE VARIABLE
SUBI 1,1
AOJA 6,EXCLM2
EXCLM7: PUSH PP,KNIL
PUTNAM 5,0(PP)
JRST EXCLM2
NEWVC4: PUSH PP,1
MOVEI 1,(4)
PUSH PP,2
CALL NEWVC1
MOVEI 8,(2)
POP PP,2
POP PP,1
RET
NEWVC5: PUSH PP,1
MOVEI 1,(5)
PUSH PP,2
CALL NEWVC1
MOVEI 8,(2)
POP PP,2
POP PP,1
RET
EXCLER: PUSH PP,2 ;SAVE NAME
MOVEI 1,0(PP)
SUBI 1,1(VP) ;COMPUTE # ARGS STACKED
HRLM 1,-3(CP) ;SAVE # ARGS
INTON ;INT'S BACK ON
HRLM PP,-2(CP) ;SAVE PPIN
JRST 0(6)
EXER1: MOVE 5,4
EXER2: JSP 6,EXCLER ;FINISH FRAME
MOVE 1,5
ERROR1 16,R ;NOT LITATOM VAR
EXER3: MOVE 5,4
EXER4: JSP 6,EXCLER ;FINISH FRAME
MOVE 1,5
ERROR1 43,R ;CANT BIND NIL OR T
;ENTRY SEQUENCE FOR SWAPPED FUNCTIONS
SBCALQ: JSYS SWPFIX ;FIX UP PREVIOUS SWAP FRAME
MOVE BR,CF ;SET LSTSWF TO CF
MOVEM BR,LSTSWF
HRL BR,40
CALL SWAPIN ;SWAPIN NEW GUY
PUSH CP,BR ;PUT ON STUFF FOR FIXUP
MOVSM BR,0(CP)
CALL 2(BR) ;BR POINTS TO HEADER, NOT 1ST INST.
SWPRET: SETZ BR, ;RETURN FROM SWAPPED FN.
SUB CP,BHC+1
RET
;COMPILED FUNCTION ENTRY ROUTINE
;AC'S: 1 - # ARGS GIVEN (FROM CALLING FN)
; 2 - FN NAME
; JSP 7,ENTERF
; XWD # ARGS EXP'D, FN TYPE
; XWD # FREE, VAR NAMES ADR
ENTERF: HRRZ 3,0(7) ;FN TYP
CAIN 3,2
JRST ENT7 ;LAMBDA ATOM
HLRZ 6,0(7) ;# ARGS EXPECTED
HRLM 6,-3(CP) ;# ARGS EXPECTED
SUBI 1,0(6) ;DIFFERENCE OF # GIVEN AND # EXPECTED
JUMPE 1,ENT2 ;EQUAL
JUMPG 1,ENT1 ;TOO MANY GIVEN
PUSH PP,KNIL ;TOO FEW GIVEN, USE NIL
AOJL 1,.-1
ENT2: PUSH PP,2 ;COMPLETE THE FRAME - NAME
HRLM PP,-2(CP) ;PPIN
MOVEI 4,1(VP) ;FIRST ARG ADDR
ENT21: HRLI 4,6
HRRZ 5,1(7) ;ADR. VAR NAMES
HRLI 5,6
ENT3: SOJL 6,2(7)
MOVE 1,@5 ;VAR NAME (VALUE CELL)
TLNE 1,-1 ;LH NON-ZERO MEANS LOCAL VAR(UNNAMED)
JRST ENT3
BINDIT 1,@4,3 ;BIND THE VARIABLE
JRST ENT3
ENT1: SUB PP,BHC(1) ;FLUSH EXTRA ARGS
JRST ENT2
ENT7: MOVEI 4,ASZ(1)
PUSH PP,4 ;# ARG GIVEN TO STACK
MOVEI 4,1(1)
HRLM 4,-3(CP) ;ARGS STACKED IS GIVEN + 1
MOVEI 6,1
PUSH PP,2
HRLM PP,-2(CP) ;SAVE PPIN
MOVEI 4,-1(PP) ;PTR TO THE BOUND ARG
JRST ENT21
;ENTERB, ANALOGOUS TO ENTERF BUF FOR SWAPPED BLOCKS.
;THE ONLY THING THAT HAS TO BE DONE DIFFERENTLY FOR SWAPPED CODE
;IS THAT THE VAR NAMES ADDR MUST BE RELOCATED, I.E. BR ADDED IN,
;AND THE LOCATION OF THE # OF ARGS IS NOW 2 MORE PLACES BACK UP
;THE STACK, I.E., -5(CP) INSTEAD OF -3(CP).
ENTERB: HRRZ 3,0(7) ;FN TYP
CAIN 3,2
JRST ENTB7 ;LAMBDA ATOM
HLRZ 6,0(7) ;# ARGS EXPECTED
HRLM 6,-5(CP) ;# ARGS EXPECTED
SUBI 1,0(6) ;DIFFERENCE OF # GIVEN AND # EXPECTED
JUMPE 1,ENTB2 ;EQUAL
JUMPG 1,ENTB1 ;TOO MANY GIVEN
PUSH PP,KNIL ;TOO FEW GIVEN, USE NIL
AOJL 1,.-1
ENTB2: PUSH PP,2 ;COMPLETE THE FRAME - STORE NAME
HRLM PP,-4(CP) ;PPIN
MOVEI 4,1(VP) ;FIRST ARG ADDR
ENTB21: HRLI 4,6
HRRZ 5,1(7) ;ADDR. VAR NAMES
ADDI 5,(BR) ;HERE'S THE EXTRA ADDI
HRLI 5,6
BENT3: SOJL 6,2(7)
MOVE 1,@5 ;VAR NAME
TLNE 1,-1 ;CHECK IF LOCAL (UNNAMED)
JRST BENT3
BINDIT 1,@4,3
JRST BENT3
ENTB1: SUB PP,BHC(1)
JRST ENTB2
ENTB7: MOVEI 4,ASZ(1)
PUSH PP,4 ;# ARG GIVEN TO STACK
MOVEI 4,1(1)
HRLM 4,-5(CP) ;ARGS STACKED IS GIVEN + 1
MOVEI 6,1
PUSH PP,2
HRLM PP,-4(CP)
MOVEI 4,-1(PP)
JRST ENTB21
; Fast ENTER's for fns with all args being localvars
; 1- # args given
; 2 - fn name
; JSP 7,ENTERn
; { 2 data words as with enterf, but not used}
;
ENTER0: SETZ 3,
SUB PP,BHC(1)
JRST ENTERY
ENTER1: MOVEI 3,1
SOJLE 1,ENTERY-1(1) ;GO PUSH MISSING ARGS
ENTERX: SUB PP,BHC(1) ;FLUSH EXTRA ARGS
JRST ENTERY
REPEAT 6,<PUSH PP,KNIL>
ENTERY: PUSH PP,2 ;PUT ON FN NAME
HRRZ 2,CF ;WE DO IT THIS WAY IN CAUSE THE FN IS SWAPPED
HRLM 3,0(2) ;SET # OF ARGS IN FRAME
SETPPI PP,2 ;SET PPIN
JRST 2(7)
ENTER3: SKIPA 3,[3]
ENTER2: MOVEI 3,2
ENTERZ: SUBI 1,0(3)
JUMPLE 1,ENTERY(1)
JRST ENTERX
ENTER4: MOVEI 3,4
JRST ENTERZ
ENTER5: MOVEI 3,5
JRST ENTERZ
ENTER6: MOVEI 3,6
JRST ENTERZ
ENTERN: MOVEI 3,ASZ(1) ;ENTERF FOR LAMBDA*
PUSH PP,3 ;# ARGS GIVEN
MOVEI 3,1(1) ;# OF ARGS+1
JRST ENTERY
;CALL BLOCK FN MAKING FRAME
;JSP 7,BIND
; FRAMESIZE,#LITS,0,,LITADR (LEFT HALF IS 6 BIT BYTES)
;# LITS DOES NOT INCLUDE FN NAME, LIT ADDR PTS TO FN NAME
;FOLLOWED BY VCELL,,ARG#
BINDB: PUSH CP,[R] ;MAKE SURE CALLER HAS A REAL RETURN
LDB 1,BINDPA ;FRAME SIZE
HRRZ 4,@0(7)
JSP 5,CFRAM
LDB 3,BINDPB
HRROI 2,@0(7)
TSC 2,3 ;GTS -#LITS-1 TO LEFT
AOBJP 2,1(7)
HRLI 3,VP
BINDB3: MOVS 4,0(2)
HLR 3,4
BINDIT 4,@3,5
AOBJN 2,BINDB3
JRST 1(7)
;DITTO FOR LAMBDA ATOM
BINDLA: PUSH CP,[R] ;MAKE SURE CALLER HAS A REAL RETURN
MOVEI 4,ASZ(1)
PUSH PP,4
ADDI 1,1
HRRZ 4,@0(7)
JSP 5,CFRAM
LDB 3,BINDPB
HRROI 2,@0(7)
TSC 2,3
AOBJP 2,1(7)
ADDI 1,0(VP)
HLRZ 4,0(2)
BINDIT 4,1,5
JRST 1(7)
BINDPA: POINT 6,0(7),5
BINDPB: POINT 6,0(7),11
;APPLY*(FN ARG1 ....)
APPLY.: SOJL 1,R ;1 HAS # ARGS TO APPLY*
HRRZ 2,1(VP) ;FN
PUSH CP,1 ;SAVE # ARGS
LDT 4,2
CAIN 4,LISTT
JRST APPLS
CAIE 4,ATOMT
JRST APPBAD ;ILLEGAL FN
MOVEI 1,0(2)
CALL ARGTYP ;GET ARGTYP
JRST APPBAD ;BAD DEF
APPL1: CAIN 1,3 ;N-LAMBDA AND NO-SPREAD?
JRST APPNS ;YES
APPS: POP CP,1 ;# ARGS
JUMPE 1,APPS1
MOVN 2,1
HRLI 2,0(2)
HRRI 2,2(VP)
HRRZ 3,0(2)
PUSH PP,3 ;MOVE ARGS DOWN
AOBJN 2,.-2
APPS1: HRRZ 2,1(VP)
STE 2,LIST ;WAS IT LAMDA
JRST APPC1
PUSH PP,2 ;YES - SAVE EXPR
MOVEI 2,CLAM-1 ;AND USE HOKEY CALL FOR NAME
AOJA 1,APPC1
APPC1: CALL EFNCAL ;JRST NOT USED CAUSE FRAME NEEDS THE CELL
RET
APPNS: POP CP,1 ;NO-SPREAD
MOVEI 6,1(1)
HRLI 6,VP
CALL LSTAR2 ;LIST ARGS
PUSH PP,1
MOVEI 1,1
JRST APPS1
APPLS: CARA 4,2
CAMN 4,KFNARG
JRST APPFNA
MOVEI 3,0(2)
CALL ARGT2
JRST APPBAD
JRST APPL1
APPBAD: POP CP,1
MOVEI 6,1(1)
HRLI 6,VP
CALL LSTAR2
PUSH PP,1(VP)
PUSH PP,1
APPB1: LCALL KFALTA,2
RET
; APPLY* OF FUNARG - PUNT BY LISTING ARGS AND CALLING APPLY
APPFNA: POP CP,1
MOVEI 6,1(1)
HRLI 6,VP
CALL LSTAR2
MOVEI 2,0(1)
HRRZ 1,1(VP)
JRST APPLY
;APPLY* FROM COMPILED CODE - STACK HAS FN AND ARGS - 1 HAS # ARGS
EVCC: MOVNI 6,0(1)
HRLI 6,PP
HRRZ 2,@6 ;GET FN
PUSH PP,2 ;AND SAVE IT
PUSH CP,1 ;SAVE # ARGS
LDT 4,2
CAIN 4,LISTT
JRST EVCLS
CAIE 4,ATOMT
JRST EVCBAD
MOVEI 1,0(2)
CALL ARGTYP
JRST EVCBAD
CAIE 1,3
JRST EVCC1
POP CP,7
CALL EVCLA
SKIPA 1,[1]
EVCC1: POP CP,1
POP PP,2 ;FN
JRST EVAF7 ;CALL FN - AND RET TO POP OFF FN
EVCLS: MOVEI 3,0(2)
CARA 2,2
CAMN 2,KFNARG
JRST EVCFNA
CALL ARGT2
JRST EVCBAD ;BAD EXPR
CAIE 1,3
JRST EVCLM1
POP CP,7 ;NO-SPREAD
CALL EVCLA
SKIPA 1,[1]
EVCLM1: POP CP,1
MOVEI 2,CLAM-1 ;HOKEY FN NAME
AOJA 1,EVAF7 ;GO CALL W/ 1 MORE ARG
EVCFNA: POP CP,7 ;FUNARG
CALL EVCLA ;PUNT - LIST ARGS
POP PP,1
POP PP,2
SUB PP,BHC+1
JRST APPLY
;LIST ARGS AND FLUSH FROM STACK
EVCLA: HRRZ 1,KNIL
JUMPE 7,EVCLAX ;NO ARGS
EVCLA1: MOVEI 2,0(1)
POP PP,1
EXCH 1,0(PP) ;GET ARG AND SAVE FN
CALL CONS
SOJG 7,EVCLA1
EVCLAX: EXCH 1,0(PP) ;SAVE LIST AND GET FN
PUSH PP,1 ;SAVE FN AGIN
RET
EVCBAD: POP CP,7
CALL EVCLA
SUB PP,BHC+1
JRST APPB1
;CONSTRUCT LIST OF ARGS
LIST: MOVEI 6,0(1)
HRLI 6,VP
LSTAR2: JUMPLE 1,FALSE ;ENTRY WITH PTR TO LAST ARG IN 6
MOVEI 7,0(1) ;COUNT
SKIPA 2,KNIL ;START WITH NIL
LSTAR1: MOVEI 2,0(1) ;LIST SO FAR
HRRZ 1,@6 ;NEXT ELEMENT
CALL CONS
SUBI 6,1
SOJG 7,LSTAR1
RET
;LIST FROM COMPILED CODE - TAKES ARGS OFF STACK
LIST3: MOVEI 6,3
JRST CLISTA
LIST4: MOVEI 6,4
JRST CLISTA
LIST2: MOVEI 1,2 ;ENTRY TO LIST 2 ELEMENTS
CLIST: JUMPLE 1,FALSE
MOVEI 6,0(1)
CLISTA: SKIPA 2,KNIL
CLIST1: MOVEI 2,0(1)
POP PP,1
CLIST2: CALL CONS
SOJG 6,CLIST1
RET
ALIST4: MOVEI 6,4 ;LIST 4 ELEMS, AND PUSH AC1 FIRST
JRST ALIST
ALIST3: MOVEI 6,3
JRST ALIST
ALIST2: MOVEI 6,2
ALIST: HRRZ 2,KNIL
JRST CLIST2
; VARIOUS COMMON EXITS FROM NON-FRAME COMPILED CODE.
URET1: SUB PP,BHC+1
POPJ CP,
URET2: SUB PP,BHC+2
POPJ CP,
URET3: SUB PP,BHC+3
POPJ CP,
URET4: SUB PP,BHC+4
POPJ CP,
URET5: SUB PP,BHC+5
POPJ CP,
URET6: SUB PP,BHC+6
POPJ CP,
URET7: SUB PP,BHC+7
POPJ CP,
;STUFF FOR BLOCK COMPILER
;BLKENT AT BEGINNING OF BLOCK TO SET UP ARGS AND CALL
;THE RIGHT SUBFN
;CALLED JSP 7,BLKENT
; #FREE,L
;THE RIGHT SUBFN
;CALLED JSP 7,BLKENT
; #FREE,,ADDR NAMES FREE VARS
; -#ENTRIES,,ADDR NAMES
; LOCS OF SUBFNS FOLLOW
SBLKNT: SKIPA 4,BR ;SWAPPED - RELOCATION IN 4
BLKENT: SETZ 4, ;RELOCATION 0
BLKEN4: HRRZ 1,CF
MOVE 3,1(7)
TLNN 3,-1 ;ANY ENTRIES?
JRST BLKEN1 ;NO - ARGS ARE IN THIS FRAME
MOVEI 2,0(1)
MOVNI 1,1 ;YES - ARGS IN PRIOR FRAME
CALL STKNTH ;FIND THE CALLER OF THE BLOCK
BLKEN1: MOVE 6,0(1) ;BASIC FRAME PTR
TLZ 6,NARM1 ;MASK FOR NON-ARG STUFF
TLC 6,-1
JRST BLKEN9
BLKEN3: MOVE 3,0(6)
TLNN 3,SHLBIT ;SHALLOW BOUND?
JRST BLKEN5 ;NO
HLRZ 3,0(6) ;YES - GET VALUE CELL
HRRZ 3,0(3) ;GET VALUE
BLKEN5: PUSH PP,3
BLKEN9: AOBJN 6,BLKEN3
MOVE 3,1(7)
TLNN 3,-1
JRST 2(7) ;NO ENTRIES
ADDI 3,(4) ;RELOCATE.
HRRZ 1,1(VP) ;THE NAME OF DESIRED ENTRY
HRLI 2,4 ;RELOCATE BY INDEXING OFF AC2.
BLKEN2: ADDI 7,1
HRRZ 5,0(3)
HRR 2,1(7)
CAIN 1,0(5)
JRST @2 ;C(2) = ADDR(4) SO IT'S RELOCATED.
AOBJN 3,BLKEN2
RET ;SHOULD BE ERROR
;BLKAPPLY MOVEI 2,**BLKENT ENTRY VECTOR
; PUSHJ CP,BLKAPP
BLKAPP: CAIE 2,7(BR) ;CALLED FROM SELF-RELOCATING CODE?
TRZA 5,-1 ;NO, SO "RELOCATE" BY 0.
HRRZI 5,(BR) ;YES, RELOCATE BY C(BR)
HRRZ 3,-1(PP) ;GET FN NAME
MOVE 6,0(2)
ADDI 6,(5) ;RELOCATE
;NOTE ON THE CAIN AT BLKAPP: THE VALUE 7 DEPENDS ON THE FACT THAT
;THE ENTRY VECTOR (**BLKENT) IS ALWAYS THE 7TH WORD OF A
;BLOCK, WHETHER SWAPPED OR NOT, AND IF SWAPPED, THE ABOVE CALLING
;SEQUENCE IS ACTUALLY
; MOVEI 2,**BLKENT(BR)
; PUSHJ CP,BLKAPP
;THIS IS A CROCK BUT IT'S FASTER THAN DOING A RANGE CHECK
;ON THE RIGHT HALF OF 0(CP) USING CBRANG AND CBRANG+1, WHICH
;IS THE SUPERCLEAN WAY. JWG.
BLKAP1: CAMN 3,0(6)
JRST BLKAPG
ADDI 2,1
AOBJN 6,BLKAP1
POP PP,2 ;NOT IN BLOCK, DO APPLY
POP PP,1
CALL APPLY
RET
BLKAPG: HRRZ 4,1(2) ;ADDR OF SUBFN
ADDI 4,(5) ;RELOCATE
HLRZ 3,-1(4) ;# ARGS NEEDED
POP PP,1
SUB PP,BHC+1
HRRZ 2,-1(4) ;CHECK FN TYP
CAIE 2,3 ;LAMA?
JRST BLKAP4
PUSH PP,1 ;YES - ARGLIST IS ARG
JRST 0(4)
BLKAP3: STE 1,LIST ;SPREAD ARGS
JRST BLKAP2
HRRZ 2,0(1)
PUSH PP,2
HLRZ 1,0(1)
BLKAP4: SOJGE 3,BLKAP3
JRST 0(4) ;GO TO SUBFN
BLKAP2: PUSH PP,KNIL ;NOT ENUF ARGS GIVEN, USE NIL
SOJGE 3,.-1
JRST 0(4)
;BLKAPPLY* CALLED MOVEI 1,#ARGS(INCL FN NAME)
; MOVEI 2,**BLKENT
; PUSHJ CP,BLKAP*
BLKAP.: CAIE 2,7(BR) ;DITTO BLKAPP, FOR BLKAPPLY*
TRZA 5,-1
HRRZI 5,(BR)
MOVEI 3,0(PP)
SUBI 3,-1(1)
HRRZ 3,0(3) ;THE FN
MOVE 6,0(2)
ADDI 6,(5)
BLKA.1: CAMN 3,0(6)
JRST BLK.G
ADDI 2,1
AOBJN 6,BLKA.1
MOVE 2,KAPP.
CALL EFNCAL
RET
BLK.G: HRRZ 4,1(2)
ADDI 4,(5)
HLRZ 3,-1(4)
SUBI 1,1(3)
JUMPL 1,BLKA.2
SUB PP,BHC(1) ;TOO MANY
BLKA.3: PUSHJ CP,0(4) ;CALL SUBFN
JRST EVNA1 ;FLUSH FN NAME AND RETURN
BLKA.2: PUSH PP,KNIL
AOJL 1,.-1
JRST BLKA.3
;ARG(VAR N) GET NTH COMPONENT OF NON-SPREAD VAR
ARGN: CALL ARGNP
HRRZ 1,0(1)
RET
;SETARG(VAR N VALUE)
SETARG: CALL ARGNP
PUSH PP,1
HRRZ 1,3(VP)
CALL EVAL
POP PP,2
HRRM 1,0(2)
RET
ARGNP: GTVALC 1,1 ;GET THE VALUE CELL
SKIPE 1 ;ERROR IF THERE IS NONE
CALL PPLOOK
JRST ARGNER ;NOT ON STACK - ERROR
PUSH PP,1 ;SAVE PSTACK POS. OF VAR
HRRZ 1,2(VP)
CALL EVAL
CALL IUNBOX
POP PP,3
HLRZ 2,0(3) ;# ARGS BOUND TO VAR
HRRZ 2,0(2)
CAILE 1,-ASZ(2)
JRST ARGNER
SUBI 1,1-ASZ(2)
ADDI 1,0(3)
RET
ARGNER: HRRZ 1,1(VP)
ERROR1 33,RESET
;EVAL
EVAL: LDT 2,1 ;GET TYPE OF THIS POINTER
CAIN 2,LISTT ;LIST?
JRST EVAF ;YES
CAIN 2,ATOMT ;ATOM?
JRST EVAT ;YES
HRRZ 2,EVATAB(2)
SKIPE 2 ;IS THERE A USER EVAL. FN FOR THIS TYPE?
CAIN 2,-1
RET ;NO - ITEM EVALS TO ITSELF
PUSH PP,2 ;YES -USE APPLY* TO EVAL THE ITEM
PUSH PP,1 ;THE ITEM
MOVEI 1,1
CALL EVCC
RET
EVAT: GTVALC 3,1 ;GET VALUE CELL
JUMPE 3,EVAA1 ;NO VALUE CELL
HRRZ 2,0(3)
CAMN 2,KNOB
JRST EVAA2 ;VALUE IS NOBIND - CHECK STACK TO SEE IF BOUND
MOVEI 1,0(2)
RET
EVAA2: PUSH PP,1
MOVEI 1,0(3)
CALL PPLOOK ;LOOK VALUE CELL UP ON STACK
JRST EVFAU1 ;NOT FOUND, U.B.A.
SUB PP,BHC+1
HRRZ 1,KNOB ;THE VALUE IS A VAILD NOBIND
RET
EVAA1: CAMN 1,KNIL ;WAS IT NIL?
RET
EVFAU: PUSH PP,1 ;NO, CALL FAULTEVAL
EVFAU1: HRRZ 2,@KCLSPA ; CHECK CLISP ARRAY FIRST
CAMN 2,KNIL ; CLISP ARRAY NIL?
JRST EVFAUX ; YES, CALL FAULTEVAL
PUSHJ CP,GETHSH ; CALL GETHASH
CAMN 1,KNIL ; NEW FORM FOUND IN TABLE?
JRST EVFAUX ; NOTHING IN ARRAY
SUB PP,BHC+1 ; POP OLD FORM
JRST EVAL
EVFAUX: LCALL KFAULT,1
RET
;FAULTEVAL IF NOT USER SUPPLIED
FAULTX: ERROR1 24,R
;APPLY AND EVAL OF NON-ATOMIC FORM
APPLY: EXCH 1,2
PUSH PP,[XWD APBLIP,0] ;SUPRESS EVALUATION OF ARGS
HRRM 2,0(PP)
JRST APPLY1
APPLY2: PUSH PP,2 ;FROM FUNARG
MOVEI 2,0(2)
JRST APPLY1
EVAF: PUSH PP,[XWD EVBLIP,0] ;SAYS DOING EVAL & HAVE WHOLE FORM
HRRM 1,0(PP) ;SAVE FORM FOR W.T.
CARA 2,1 ;NON-ATOMIC FORM, GET CAR
CDRA 1,1
APPLY1: TLZ F,EVLFLG
PUSH PP,1 ;ARG-LIST
PUSH PP,2 ;FN
EVNC5: LDT 3,2 ;GET TYPE OF CAR
CAIN 3,LISTT ;LIST?
JRST EVNAC ;YES, EVAL OF NON-ATOMIC CAR OF FORM
CAIE 3,ATOMT ;ATOM?
JRST UDF ;NO, ILLEGAL
MOVEI 1,0(2)
HRRZ 3,1(2)
CAMN 3,KNIL
JRST UDF ;NO DEF, TRY VALUE
CALL ARGTYP ;ARGS ARE EVAL/NOEVAL, SPREAD/NOSPREAD
JRST UDF ;DEF EXISTS BUT IS BAD
POP PP,2
HRLI 2,FNBLIP(1) ;KEEP ARGTYPE BITS WITH FN NAME
EVNC2: POP PP,1
HLRZ 3,0(PP) ;EVAL-APPLY FLAG
PUSH CP,[0] ;INIT # ARGS
TLNE 2,1 ;IS THIS NO-EVAL AND NO-SPREAD?
TLNN 2,2
JRST EVAF3 ;NO, GO MAP ARG LIST
HRLI 1,AVBLIP
PUSH PP,1 ;YES, USE CDR OF FORM AS ARG
AOS 0(CP)
JRST EVAF6
EVAF3: TRNE 3,APBLIP ;IS THIS AN APPLY?
TLO 2,1 ;YES, DON'T EVAL ARGS
EVAF1: STE 1,LIST ;ANY LIST LEFT?
JRST EVAF2 ;NO
HRLI 1,PRBLIP
PUSH PP,1 ;YES, SAVE IT
PUSH PP,2 ;AND FN NAME
CARA 1,1 ;GET NEXT ARG
TLNN 2,1 ;EVAL IT?
CALL EVAL ;YES
HRLI 1,AVBLIP ;FLAG ARGVAL FOR WT
POP PP,2
EXCH 1,0(PP) ;PUT ARG ON STACK
AOS 0(CP)
CDRA 1,1 ;GET REST OF LIST
JRST EVAF1
EVAF2: CAME 1,KNIL
ERROR1 31,R ;CDR NOT LIST OR NIL - ERROR???
EVAF6: POP CP,1 ;GET NUMBER OF ARGS STACKED
MOVEI 2,0(2) ;CLEAR LEFT NAME
CAIE 2,CLAM-1 ;HOKEY FN?
JRST EVAF7
ADDI 1,1 ;YES - 1 MORE ARG FOR NOW
POP CP,3 ;THE EXPR
PUSH PP,3
EVAF7: PUSHJ CP,EFNCAL ;CALL FN
EVNA1: SUB PP,BHC+1 ;FLUSH THE BLIP
RET
;NON-ATOMIC CAR OF FORM
EVNAC: CARA 3,2
CAMN 3,KFNARG
JRST EVNFA
MOVEI 3,0(2)
CALL ARGT2 ;IS LAMBDA/NLAMBDA?
JRST EVNC1 ;NO
MOVSI 2,0(1) ;ARGTYP BITS TO LH
HRRI 2,CLAM-1 ;HOKEY NAME FOR LAMBDA'S
POP PP,1 ;EXPR
PUSH CP,1 ;SAVE IT OUT OF THE WAY
JRST EVNC2 ;CONTINUE WITH EVAL
CLAM: CALL LAMCAL ;TO CALL OPEN LAMBDAS
EVNC1: MOVE 1,0(PP) ;GET CAR OF FORM
TLNN F,EVLFLG
JRST UDF
CALL EVAL ;EVAL IT TO GET FN NAME
EVNC6: CAMN 1,0(PP)
JRST UDF ;VALUE IS SELF - ERROR
CAME 1,KNIL
CAMN 1,KNOB
JRST UDF ;NIL OR NOBIND IS ERROR
EVNC3: MOVEM 1,0(PP) ;OTHERWISE, TRY AGAIN
MOVEI 2,0(1)
TLO F,EVLFLG
JRST EVNC5
UDF: MOVE 1,-2(PP) ;BLIP,,FORM
SUB PP,BHC+3
TLZE 1,EVBLIP
JRST EVFAU ;GO TO FAULTEVAL
TLZN 1,APBLIP
JRST UDF1
ADD PP,BHC+3
HRRZ 1,0(PP)
EXCH 1,-1(PP) ;FAULTAPPLY WANTS FN, ARGS
HRRZM 1,0(PP) ;... WE HAVE ARGS,FN
LCALL KFALTA,2
JRST EVNA1 ;FLUSH BLIP
UDF1: HRRZ 2,2(PP) ;FUNARG IN EVAL - DONT HAVE FORM????
CALL CONS
JRST EVFAU
;FUNARG
EVNFA: CDRA 2,2
CDRA 2,2
CARA 2,2 ;POS
STE 2,STKP
JRST EVNFAB
MOVE 3,0(2) ;UNBOX
JUMPE 3,EVNFAB ;RELEASED PTR
PUSH CP,[EVNFA1] ;CLOSE OUT CURRENT FRAME
HRLM PP,0(CP)
HRRZ 1,CF
SETCPO CP,1
INTOFF
HRRZ 6,CF
JSYS SWCNTX ;SWITCH TO THE FUNARG CONTEXT
MOVSI 2,1
ADDM 2,USEWD(3) ;INCREM USE(FUNARG FRAME)
MOVEI 2,1(CP) ;MAKE A DUMMY FRAME
MOVEM 2,CF
PUSH CP,PP
HRRZS 0(CP)
PUSH CP,3 ;ALINK
PUSH CP,6 ;CLINK
PUSH CP,HCRETC
PUSH PP,KNIL ;FRAME NAME
HRLM PP,-2(CP) ;SET PPI
INTON
GETPPO 3,1
MOVE 2,0(3) ;GET FUNARG FROM FORMER FRAME
CDRA 2,2
CARA 2,2 ;THE FN
HRRZ 1,-1(3) ;ARG-LIST
HLL 2,-2(3) ;OLD BLIP
TLZ 2,EVBLIP
CALL APPLY2
RET
EVNFA1: SUB PP,BHC+3
RET
EVNFAB: MOVEI 1,0(2)
JRST STKERR
;ROUTINE TO SEARCH FOR A BINDING CELL OF SOME ARG
; 1= PTR TO BINDING, 2=FRAME, 3 = RETURNED RESULT
; 4,5,6,7 = TEMPS
FNDBND: MOVEI 3,(1) ;INIT TO GIVEN PTR
MOVE 4,(1)
TLNN 4,SHLBIT ;LOCAL VAR?
FNDRET: RET ;YES
GETBIB 4,2 ;DEEP BOUND?
JUMPN 4,FNDRET ;JUMP IF SO
HLRZ 3,(1) ;GET VAL CELL PTR.
MOVEI 4,(3) ;SAVE THE "NAME" FOR CHECKING
HRRZ 7,CF ;STACK FRAME
HRLI 5,6 ; 6 WILL HAVE ARG # TO CHECK
FNDLOP: JUMPE 7,FNDRET ;NO MORE ENTRIES
HRR 5,0(7) ;PTR TO FIRST ARG -1
HLRE 6,NARWD(7) ;GET # ARGS
JUMPLE 6,FNDLP2 ;NO ARGS
FNDLP3: MOVEI 2,@5 ;GET ARG ADR
CAIN 1,(2) ;SAME ENTRY AS ORIGINAL?
RET ;YES - DONE
HLRZ 2,(2) ;GET "NAME"
CAIN 4,(2) ;RIGHT NAME?
MOVEI 3,@5 ;YES - SAVE ADDR.
FNDLP2: SOJG 6,FNDLP3 ;DECR ARG COUNT AND LOOP
GETAL 7,7 ;GET NEXT LINK VIA ALINK
JRST FNDLOP
;ROUTINE TO SEARCH PARAMETER STACK FOR VARIABLE BINDING
;CALLED WITH ATOM IN 1
;SKIPS IF FOUND AND RETURNS POINTER TO STACK IN 1 & FRAME IN 2
;DOES NOT SKIP, RETURNS ATOM IN 1 IF NOT FOUND
;PPLOOK LOOKS BACKWARD FROM CURRENT FRAME IN CF
;PPLOK2 LOOKS BACKWARD FROM FRAME IN AC2
;NOTE NOW CLOBBERS AC5 WHERE DIDNT BEFORE
PPLOOK: HRRZ 2,CF ;USE CURRENT FRAME
PPLOK2: HRLI 3,4
PPLOK3: JUMPE 2,PPLKR ;CANT FIND
HRR 3,0(2) ;PTR TO FRST ARG -1
HLRZ 4,NARWD(2) ;GET # ARGS
TRZ 4,NARM1
PPLK6: JUMPLE 4,PPLK2 ;NO ARGS
PPLK1: HLRZ 5,@3
CAIN 5,0(1)
JRST PPLK3 ;YES
SOJG 4,PPLK1 ;NO, COUNT ARGS
PPLK2: GETAL 2,2 ;ALINK
JRST PPLOK3
PPLK3: MOVEI 1,@3 ;ADDR OF BINDING
PPLK31: AOS 0(CP) ;GOOD, RETURN SKIPING
PPLKR: RET
;EVALV(VAR POS)
EVALV: CALL FNDVAL ;FIND THE VAL PTR
SKIPA 1,KNOB ;NO VALUE CELL
HRRZ 1,0(3) ;GET VALUE
RET
; FIND THE VALUE OF AN ATOM WRT AN CONTEXT (AC2)
FNDVAL: MOVEI 4,0(1) ;MOVE ATOM NAME
GTVALC 5,4 ;GET VALUE CELL
JUMPE 5,FNDVL1 ;NO VALUE CELL
CAMN 2,KT ;SPECIAL CHECK FOR GLOBAL
JRST FNDVL5
CAMN 2,KNIL ;SPECIAL CHECK FOR CURRENT VALUE
JRST FNDVL6
MOVEI 1,0(2)
CALL STKGP
JUMPE 1,STKER2
MOVEI 2,0(1)
MOVEI 1,0(5)
MOVEI 6,(2) ;SAVE FOR FNDVL4
CALL PPLOK2
JRST FNDVL2 ;NOT ON STACK
CALL FNDBND ;GET THE PTR TO THE REAL VALUE
AOS 0(CP) ;GOT BINDING, SKIP RETURN
FNDVL1: RET
FNDVL6: MOVEI 3,0(5) ;JUST RETURN CURRENT VALUE
AOS 0(CP)
RET
FNDVL5: SETZ 6, ;LOOK FOR GLOBAL BINDING
MOVEI 1,(5) ;GET BACK VALUE CELL
FNDVL2: MOVEI 8,(1) ;LOOKING FOR TOP VALUE, SAVE CELL PTR
HRRZ 2,CF ;START HERE
CAIE 2,(6) ;IF EQ TO CURRENT - NO NEED TO SEARCH STACK
FNDVL4: CALL PPLOK2 ;LOOK FOR IT
JRST [MOVEI 3,(8) ;CAN'T FIND ANOTHER, RETURN PREVIOUS
AOS 0(CP)
RET]
MOVEI 8,(1) ;SAVE AS PREVIOUS
HLRZ 1,(1) ;GET BACK NAME
GETAL 2,2 ;STEP TO NEXT FRAME
JRST FNDVL4 ;TRY AGAIN
; SETTOPVAL AND GETTOPVAL
STOPVL: STE 1,ATOM ;ATOM?
ERROR1 16,R ;NO - ERROR
CAME 1,KT ;T
CAMN 1,KNIL ;NIL?
CALL SETERR ;YES , ERROR
HRRZ 2,KT ;SET WRT GLOBAL ENV.
CALL FNDVAL ;FIND THE BINDING
JRST [ CALL NEWVC4 ;MAKE A VALUE CELL
MOVEI 3,(8)
JRST .+1]
HRRZ 1,2(VP) ;GET THE NEW VALUE
HRRM 1,(3) ;STORE THE NEW VALUE
RET
GTOPVL: HRRZ 2,KT ;EVALV(ARG1,T)
JRST EVALV
; AT2VC - GET THE VALUE CELL OF AN ATOM
AT2VC: STE 1,ATOM ;ATOM?
ERROR1 33,AT2VC ;NO
GTVALC 2,1
SKIPN 2 ;SEE IF ALREADY GOT ONE.
CALL NEWVC1 ;GET THE VC.
MOVEI 1,0(2)
RET
;GET NEW VALUE CELL FOR ATOM IN 1, RESULT IN 2
NEWVC1: PUSH PP,1
CALL SAV27
HLRZ 1,2(1) ;GET PNAME PTR
CALL HENTER ;FIND WHERE ATOM IS IN HASH TABLE
JRST .+1 ;ATOM ALWAYS EXISTS
CALL RES27
ANDI 1,MPS ;KEEP LO BITS FROM HASH ADDR
HRRZ 2,HENTID
LSH 2,LPS
IORI 1,0(2)
HRRZ 2,ATOMHT ;MAKE A 13 BIT INDEX INTO HASH TABLE
NEWV1C: CAILE 2,17777
JRST NEWV1D
LSH 1,↑D23
HRR 1,KNOB
NEWV1B: SKIPN 2,FREEVC
JRST NEWV1A
INTOFF
EXCH 1,0(2)
MOVEM 1,FREEVC
INTON
POP PP,1
STVALC 2,1
RET
NEWV1D: LSH 2,-1
LSH 1,-1 ;REDUCE INDEX TO 13 BITS
JRST NEWV1C
NEWV1A: PUSH CP,1
MOVEI 1,VCELLT
CALL GC1
POP CP,1
JRST NEWV1B
;PUSH LIST FUNCTIONS
;INTERNAL STKPOS, 1 IS FN NAME, 2 IS HOW MANY
;-ALONG CLINK,+ ALINK, 3 IS UNBOXED STARTING FRAME
STKPOS: CAMN 1,KNIL ;FRST ARG NIL MEANS CF
JRST STKP4
MOVE 4,STKPC ;=GETCL
JUMPL 2,.+3
MOVE 4,STKPA ;=GETAL
MOVN 2,2
MOVEM 4,STKPX
STKP3: GETNAR 4,3
ADD 4,0(3)
HRRZ 4,1(4) ;NAME
CAIN 1,0(4)
JRST STKP1
STKP2: XCT STKPX ;GETCL OR AL
JUMPN 3,STKP3
SKIPA ;FAIL - RETURN 0
STKP1: AOJL 2,STKP2
MOVEI 1,0(3) ;RETURN UNBOXED POS
RET
STKP4: HRRZ 1,CF
JUMPLE 1,STKERR ;SHOULDNT HAPPEN
RET
STKPC: GETCL 3,3
STKPA: GETAL 3,3
U STKPX
;USER STKPOS(FN N IPOS OPOS)
USTKPO: CAMN 2,KNIL
SKIPA 1,[-1]
PIUNBX 2
PUSHN 1
HRRZ 1,3(VP)
CALL STKGP
JUMPE 1,STKER3 ;NO GOOD POS
MOVEI 3,0(1)
HRRZ 1,1(VP)
POPN 2
CALL STKPOS
CAMN 1,CF
JRST STKER3
HRRZ 2,4(VP)
JRST USTKN2 ;GO FOOL WITH OPOS
STKER1: SKIPA 1,1(VP)
STKER3: HRRZ 1,3(VP)
STKERR: ERROR1 23,RESET
STKER2: HRRZ 1,2(VP)
JRST STKERR
;CONVERT A POS ARGUMENT TO AN UNBOXED POS
STKGP: CAMN 1,KNIL ;NIL MEANS CURRENT
JRST STKGN
CAMN 1,KT ;T MEANS TOP
JRST STKGT
LDT 2,1
CAIN 2,STKPT
JRST STKGS
CAIN 2,ATOMT
JRST STKGA
CAIL 2,FLOATT
CAILE 2,SMALLT
JRST STKERR ;NONE OF ABOVE - ERROR
CALL IUNBOX
HRRZ 2,CF ;NUMBER - DO STKNTH (N CF)
JRST STKNTH
STKGT: HRRZ 1,CF ;FIND TOP COMTROL FRAME
STKGT1: GETCL 2,1
JUMPE 2,STKGR
MOVEI 1,0(2)
JRST STKGT1
STKGS: SKIPN 0(1) ;STACK POINTER WAS RELEASED
ERROR1 36,RESET
SKIPA 1,0(1) ;STACK POS - UNBOX
STKGN: HRRZ 1,CF ;CURRENT FRAME
STKGR: RET
STKGA: MOVNI 2,1 ;ATOM - DO STKPOS(ATOM -1 CF)
HRRZ 3,CF
JRST STKPOS
;INTERNAL STKNTH - 1 IS NUMBER, 2 IS UNBOXED POS
STKNTH: MOVE 3,STKPC ;=GETCL
JUMPL 1,.+3 ;FOR N <0
MOVE 3,STKPA ;=GETAL - FOR N>0
MOVN 1,1
MOVEM 3,STKPX
MOVEI 3,0(2)
JUMPE 1,STKN2 ;N=0 - JUST RETURN POS
STKN1: XCT STKPX ;FOLLOW APPROPRIATE LINKS
JUMPE 3,STKN2
AOJL 1,STKN1
STKN2: MOVEI 1,0(3)
RET
;USER STKNTH (N IPOS OPOS) N=0 WILL COPY IPOS INTO OPOS OR NEW
USTKNT: CAMN 1,KNIL
SKIPA 1,[-1] ;FIRST ARG NIL MEANS -1
CALL IUNBOX
PUSHN 1
HRRZ 1,2(VP)
CALL STKGP
JUMPE 1,STKER2 ;ERROR - BAD POS ARG
MOVEI 2,0(1)
POPN 1
CALL STKNTH
CAMN 1,CF
JRST STKER2 ;CANT BOX CF
HRRZ 2,3(VP)
USTKN2: STE 2,STKP
JRST USTKN1 ;OPOS IS IGNORED IF NOT STACK POINTER
MOVSI 3,1
INTOFF
SKIPE 1
ADDM 3,USEWD(1) ;INCREM USE
EXCH 1,0(2) ;PUT RESULT IN OLD BOX
EXCH 1,2 ;1 HAS OPOS, 2 HAS C(OPOS)
CALL FLFR ;FLUSH OPOS
INTON
SKIPN 0(1)
JRST FALSE ;POS NOT FOUND - RETURN NIL
RET
USTKN1: JUMPE 1,FALSE ;DITTO
JRST MKSTKP ;GO BOX RESULT
;STKSCAN(ATOM POS OPOS) - FIND BINDING OF ATOM - CHASE ALINKS
STKSCN: MOVEI 1,0(2)
CALL STKGP
JUMPE 1,STKER2 ;BAD POS
MOVEI 2,0(1)
HRRZ 1,1(VP)
GTVALC 1,1 ;GET VAL. CELL
JUMPE 1,FALSE ;IF NONE - THEN IT CANT BE ON STACK
CALL PPLOK2
JRST FALSE ;NOT ON STACK
STKSC2: MOVEI 1,0(2) ;RETURN FRAME IN WHICH BOUND
HRRZ 2,3(VP)
JRST USTKN2
;STACK CLEARING FUNCTIONS
;RETFROM(POS VAL FLG)
RETFRM: CALL STKGP
JUMPE 1,STKER1 ;BAD POS
GETCL 1,1
JUMPE 1,STKER1 ;CANT RETFROM TOP LEVEL
JRST RETT2 ;GO INTO RETTO
FLED1: STE 1,STKP ;INTERNAL FLUSH OF ED
RET ;NOT STK PTR
MOVEI 2,0 ;SET TO 0
EXCH 2,0(1) ;GET CONTENTS
STE 2,STACK
RET ;ALREADY FLUSHED
MOVSI 3,-1 ;DECREM. USE OF FRAME
ADDM 3,USEWD(2) ;BUT DONT FLUSH CAUSE STILL NED IT
RET
;RETTO(POS VAL FLG)
RETTO: CALL STKGP
JUMPE 1,STKER1
RETT2: IFDEF MAXC,< ; byte lisp BIND doesn't store return
HRRZ 2,4(1) ; so check to make sure not RETFROM'ing a *PROG*LAM
CAIE 2,BRET2
CAIN 2,BRET1
ERROR0 23,RESETE
> HRRZ 2,3(VP) ;FLG
INTOFF
CAME 1,CF
CAMN 2,KNIL
JRST RETT1
PUSH PP,1
HRRZ 1,1(VP) ;GET UNBOXED POS
CALL FLED1 ;RELEASE STKP (JUST DECR USE)
POP PP,1
RETT1: HRRZ 2,2(VP)
RETT3: JSP 7,UNSTK ;UNWIND THE STACK - ENTRY FROM RETURN
MOVE 3,1 ;MOVE THINGS FOR PPRC31
MOVE 1,2
JRST PPRC31 ;LET THE "RETURNER" DO THE REST
;ENVEVAL(FORM APOS CPOS AFLG CFLG)
;NOTE - OLD STKEVAL(POS FORM) BECOMES ENVEVAL(FORM POS 1)
;AND OLD RETEVAL(POS FORM) BECOMES ENVEVAL(FORM POS POS)
ENVEVL: HRRZ 1,3(VP) ;CPOS
CALL STKGP
JUMPE 1,STKER3 ;BAD POS
CAMN 1,CF ;USE 0 AS SHORT FOR CF IN CASE IT MOVES
MOVEI 1,0
PUSH PP,1 ;SAVE UNBOXED POS
HRRZ 1,2(VP) ; APOS
CAIN 1,@3(VP) ;APOS EQ CPOS?
JRST ENVEV2 ;YES - AVOID DOUBLE SEARCH
CALL STKGP
JUMPE 1,STKER2 ;BAD POS
CAMN 1,CF
MOVEI 1,0 ;AGAIN USE 0 AS SHORT FOR CF
ENVEV3: INTOFF
PUSH PP,1
SKIPN 3,1
HRRZ 3,CF
MOVSI 4,1
CAME 1,-1(PP) ;APOS EQUAL CPOS?
ADDM 4,USEWD(3)
HRRZ 6,CF ;OLD ALINK
CAIE 3,0(6) ;SAME?
JSYS SWCNTX ;NO - CHANGE CONTEXT
HRRZ 1,3(VP) ;GET BOXED BACK
HRRZ 2,5(VP) ;CFLG
CAME 2,KNIL
CALL FLED1 ;FLG T - FLUSH THE STK PTR&DECR. USE
HRRZ 1,2(VP) ;GET BOXED APOS AGAIN
HRRZ 2,4(VP) ;AFLG
CAME 2,KNIL
CALL FLED1 ;ALFG T - FLUSH STK PTR AND DECR USE
POP PP,2 ;UNBOXED APOS
JUMPN 2,.+2
HRRZ 2,CF
POP PP,1 ;UNBOXED CPOS
JUMPN 1,.+2
HRRZ 1,CF
HRRZ 3,1(VP) ;FORM
MOVEM 3,ENVEVT ;SAVE OFF STACK
JSP 7,UNSTK2 ;INCR. USE(CPOS) & FLUSH FROM CF TO CPOS
MOVEI 3,1(CP)
MOVEM 3,CF ;SET CF BEFORE PUSH
MOVEI VP,0(PP) ;NOTE ALTHOUGH THE FRAME HAS NO ARGS
;VP MUST BE SET SO PPRC WILL WORK
PUSH CP,VP ;MAKE DUMMY FRAME
PUSH CP,2 ;ALINK
HRLM PP,0(CP) ;PPIN
PUSH CP,1 ;CLINK
PUSH CP,HCRETC ;FLG
PUSH PP,KENV ;PHONEY NAME
HRLM PP,-2(CP) ;SAVE PPIN
MOVE 1,ENVEVT
INTON
JRST EVAL ;AND GO EVAL FORM
ENVEV2: HRRZ 1,0(PP) ;GET UNBOXED CPOS=APOS
JRST ENVEV3
HCRETC: XWD 0,PPRC
U ENVEVT
; ENVAPPLY (FN ARGS APOS CPOS AFLG CFLG)
ENVAPP: HRRZ 1,4(VP) ;CPOS
CALL STKGP
JUMPE 1,STKER4 ;BAD POS
CAMN 1,CF
MOVEI 1,0
PUSH PP,1 ;SAVE UNBOXED POS
HRRZ 1,3(VP) ; APOS
CAIN 1,@4(VP)
JRST ENVAP2
CALL STKGP
JUMPE 1,STKER3 ;BAD POS
CAMN 1,CF
MOVEI 1,0
ENVAP3: INTOFF
PUSH PP,1
SKIPN 3,1
HRRZ 3,CF
MOVE 6,CF ;OLD ALINK
CAIE 3,(6) ;SAME?
JSYS SWCNTX ;NO - CHANGE CONTEXT
MOVSI 4,1
CAME 1,-1(PP) ;APOS EQUAL CPOS?
ADDM 4,USEWD(3) ;NO - INCREM USE(APOS)
HRRZ 1,4(VP) ;GET BOXED BACK
HRRZ 2,6(VP) ;CFLG
CAME 2,KNIL
CALL FLED1 ;FLG T - FLUSH THE STK PTR&DECR. USE
HRRZ 1,3(VP) ;GET BOXED APOS AGAIN
HRRZ 2,5(VP) ;AFLG
CAME 2,KNIL
CALL FLED1 ;ALFG T - FLUSH STK PTR AND DECR USE
POP PP,2
JUMPN 2,.+2
HRRZ 2,CF
POP PP,1
JUMPN 1,.+2
HRRZ 1,CF
HRRZ 3,1(VP) ;FN
HRL 3,2(VP) ;ARG LIST
MOVEM 3,ENVEVT ;SAVE OFF STACK
JSP 7,UNSTK2 ;INCR. USE(CPOS) & FLUSH FROM CF TO CPOS
MOVEI 3,1(CP)
MOVEM 3,CF ;SET CF BEFORE PUSH
MOVEI VP,0(PP)
PUSH CP,VP ;MAKE DUMMY FRAME
PUSH CP,2 ;ALINK
HRLM PP,0(CP) ;PPIN
PUSH CP,1 ;CLINK
PUSH CP,HCRETC ;FLG
PUSH PP,KENV ;PHONEY NAME
HRLM PP,-2(CP) ;SAVE PPIN
HRRZ 1,ENVEVT
HLRZ 2,ENVEVT
INTON
JRST APPLY ;AND GO APPLY
ENVAP2: HRRZ 1,0(PP) ;GET UNBOXED CPOS=APOS
JRST ENVAP3
STKER4: HRRZ 1,4(VP)
JRST STKERR
; RESUME(ED VALUE)
RESUME: HRRZ 2,CF
GETCL 2,2
STE 1,STKP
ERROR1 23,RESETE ; "ILLEGAL STACK ARG"
MOVSI 3,1
INTOFF
JUMPE 2,.+2
ADDM 3,USEWD(2)
EXCH 2,0(1) ; Put result in old box
CALL FLFR
INTON
HRRZ 1,2(VP)
MOVEM 1,1(VP)
HRRZ 2,3(VP)
MOVEM 2,2(VP)
HRRZ 3,KT
MOVEM 3,3(VP)
JRST RETTO
; THE HANDY DANDY CONTEXT SWITCHER.
; NEW ACCESS CHAIN IN AC3
; OLD ACCESS CHAIN IN AC6
; AC'S 1-7 ARE PRESERVED - EXCEPT LEFT HALF 3 IS CLEARED
; AC 8 IS CLOBBERED
GCAC6=GCAC2+4
GCAC3=GCAC2+1
GCAC7=GCAC2+5
NEW=GCAC3
; A=8
; B=5
; BL=6
SWCNTX: XWD SWCNTR,.+1
TLZ 3,-1
MOVEM 2,GCAC2
MOVE 2,[XWD 3,GCAC3]
BLT 2,GCAC7
MOVEI 6,0(6)
HRRZM 6,OLD
HRRZ 8,NEW
INTOFF
JUMPE 8,SW2 ;SO CAN UNWIND TO TOP EASILY
SW1: GETEIB 7,8
JUMPE 7,SW2 ;1. if A is current then goto 2
GETAL 5,8 ; B←A.ALINK
SETAL 6,8 ; A.ALINK←BL
MOVEI 6,0(8) ; BL←A
SKIPE 8,5 ; A←B
JRST SW1 ; goto 1
SW2: CAMN 8,OLD
JRST SW3 ;2. if OLD=A then goto 3
MOVE 4,OLD
SW2A: MOVE 2,BASWD(4)
TLZ 2,NARM1
MOVSI 3,SWPEIB
IORM 3,(4) ; mark OLD as non-current
IFDEF MAXC,<UNWND>
IFNDEF MAXC,<
JSP 7,UNWIND ; unwind OLD, mark OLD.BASIC as "deep"
>
HRRZ 4,OLD ; OLD←OLD.ALINK
GETAL 4,4
MOVEM 4,OLD
CAIE 4,(8)
JRST SW2A ; goto 2
SW3: CAMN 8,NEW
JRST SW6 ;3. if A=NEW then exit
SW4: GETAL 5,6 ; B←BL.ALINK
SETAL 8,6 ; BL.ALINK←A
MOVE 2,BASWD(6)
TLZ 2,NARM1
TLC 2,-1
MOVSI 3,SWPEIB
XORM 3,(6) ; mark BL as current
IFDEF MAXC,<REWND>
IFNDEF MAXC,<
JSP 7,REWIND ; rewind BL, mark BL.BASIC as shallow
>
CAMN 6,NEW
JRST SW6 ; if BL=NEW then exit
MOVEI 8,(6) ; A←BL
MOVEI 6,(5) ; BL←B
JRST SW4 ; goto 4
SW6: INTON ;exit.
MOVE 7,[XWD GCAC2,2]
BLT 7,7
JRST @SWCNTR
U SWCNTR
U OLD
;STKARG(N POS) - VALUE OF NTH ARG AT POS (WAS BEFORE BINDING OF)
STKARG: CALL STKAR1
CALL FNDBND ;POINT TO VALUE
HRRZ 1,0(3) ;VALUE
RET
STKANM: CALL STKAR1
HLRZ 1,0(1) ;ARG NAME
TRNN 1,SHLBIT ;LOCAL VAR?
SKIPA 1,KNIL ;YES - RETURN NIL
CALL VCTOAT ;CONVERT TO ATOM
RET
;SETSTKARG(N POS VAL) - N NUM IS ARG#, N ATOME IS ARG NAME
SSTKAR: CALL STKAR1
CALL FNDBND ;POINT TO VALUE
HRRZ 1,3(VP)
HRRM 1,0(3)
RET
;SETSTKARGNAME(N POS NAM)
SSTKAN: CALL STKAR1
PUSH PP,1
PUSH PP,2
HRRZ 1,3(VP) ;GET 3RD ARG VAL CELL
STE 1,ATOM ;ATOM?
ERROR1 33,R ;NO, ILLEGAL ARG.
GTVALC 2,1
SKIPN 2
CALL NEWVC1 ;NO CELL - CREATE ONE
MOVEI 3,(2)
POP PP,2
POP PP,1
MOVE 4,(1) ;GET BINDING ENTRY
TLNN 4,SHLBIT ;LOCAL VAR?
JRST ILARG1 ;YES - ERROR
GETBIB 4,2 ;DEEP BOUND?
SKIPN 4
JRST STKAN2 ;NO - DO IT THE HARD WAY
HRLM 3,(1) ;YES - PUT IN THE NAME
JRST STKAN3
STKAN2: PUSH PP,3 ;SAVE NEW NAME
PUSH PP,2 ;SAVE FRAME
CALL FNDBND ;FIND THE OLD BINDING
POP PP,2 ;GET BACK FRAME
EXCH 3,0(PP) ;GET BACK NEW NAME
INTOFF
HRLM 3,0(1) ;CHANGE NAME
CALL FNDBND ;GET THE NEW BINDING
POP PP,2 ;GET BACK OLD BINDING
HRRZ 4,(2) ;UNBIND OLD
HRRZ 5,(1)
HRRM 5,(2)
HRRZ 5,(3) ;BIND NEW
HRRM 5,(1)
HRRM 4,(3)
INTON
STKAN3: HRRZ 1,3(VP) ;RETURN NEW NAME AS VALUE
RET
STKAR1: LDT 3,1
CAIE 3,ATOMT
JRST STKAR2
CALL FRMSCN ;TRANSFORM ARG NAME TO NUMBER
CAMN 1,KNIL
JRST ILARG1 ;NO SUCH ARG THIS FRAME - ERROR
MOVEI 1,@3 ;LOC OF BINDING
RET
STKAR2: MOVEI 1,0(2)
CALL STKGP
CAMN 1,CF
JUMPE 1,STKER2
PUSH PP,1
HRRZ 1,1(VP) ;NUMBER OF ARG AT THIS POSITION
CALL IUNBOX
POP PP,2
JUMPLE 1,ILARG1 ;N NEG?
GETNAR 7,2
CAILE 1,0(7)
JRST ILARG1 ;N TOO BIG
ADD 1,0(2)
TLZ 1,-1 ;MAKE SURE LEFT HALF IS ZERO FOR FNDBND
RET
STKNRG: CALL STKGP
JUMPE 1,STKER1
GETNAR 1,1 ;CHANGE FOR COMPILER?????????
JRST MKN
;STKNTHNAME(N IPOS)
STKNNM: CAMN 1,KNIL
SKIPA 1,[-1]
CALL IUNBOX
PUSHN 1
HRRZ 1,2(VP)
CALL STKGP
JUMPE 1,STKER2
MOVEI 2,0(1)
POPN 1
CALL STKNTH
JUMPE 1,FALSE
JRST STKNA1
;STKNAME(POS)
STKNAM: CALL STKGP
JUMPE 1,STKER1
STKNA1: GETNAR 2,1 ;# ARGS
ADD 2,0(1) ;BEG ARGS -1
HRRZ 1,1(2) ;FN NAME
RET
;SETSTKNAME(POS NAM)
SSTKNM: CALL STKGP
JUMPE 1,STKER1
GETNAR 2,1
ADD 2,0(1)
HRRZ 1,2(VP)
HRRM 1,1(2)
RET
;FRAMESCAN (ATOM POS)
;GETS RELATIVE POSITION OF BINDING IN A FRAME - NIL IF NOT THERE
FRMSCN: MOVEI 1,0(2)
CALL STKGP
MOVEI 2,0(1) ;WANT FRAME LEFT IN 2
JUMPE 2,STKER2
HRRZ 1,1(VP)
GTVALC 1,1 ;GET VAL CELL OF ATOM
JUMPE 1,FALSE ;NONE - CANT BE IN FRAME
HRLI 3,4
GETNAR 4,2 ;LIKE PPLOOK BUT DONT GO OUTSIDE FRAME
FRMSC9: HRR 3,0(2)
JUMPLE 4,FALSE
FRMSC1: HLRZ 5,@3
CAIN 5,0(1)
JRST FRMSC2
SOJG 4,FRMSC1
JRST FALSE ;NOT IN THIS FRAME
FRMSC2: MOVEI 1,0(4)
ADDI 1,ASZ ;GUARANTEED SMALL
RET ;RETURN N , AND @3 HAS BINDING LOC
;FIND BLIP(TYP IPOS FLG)
;FLG T MEANS FIND HOW MANY AT POS (DOESNT GO OUT OF POS)
;FLG NUMBER MEANS FIND NTH ONE BEGINNING AT POS (NIL=0)
FNDEVL: PUSH PP,3 ;IN CASE CALLE D FROM BLIPSCAN
MOVE 4,[XWD -NBLIPS,BLIPTB]
FNDEVA: MOVE 5,0(4)
CAMN 1,0(5)
JRST FNDEVB
AOBJN 4,FNDEVA
MOVEI 4,0(1) ;NO SUCH BLIP, USE TYP AS IS
JRST .+3
FNDEVB: HLRZ 4,5
ANDI 4,777770
MOVEM 4,FNDEVT
MOVEI 1,0(3)
CAMN 1,KNIL
JRST FNDEV9
CAMN 1,KT
SKIPA 1,[0]
CALL IUNBOX
PUSHN 1
FNDEV9: HRRZ 1,2(VP)
CALL STKGP
JUMPE 1,STKER1
FNDEV5: GETPPI 2,1
MOVEI 3,0(PP)
CAMN 1,CF
JRST FNDEV1
GETPPO 3,1
FNDEV1: SUBI 3,0(2)
JUMPE 3,FNDEV2
HRLI 2,3
FNDEV3: HLRZ 4,@2
ANDI 4,777770
CAMN 4,FNDEVT
JRST FNDEV4
FNDEV7: SOJG 3,FNDEV3
FNDEV2: HRRZ 4,0(PP)
CAMN 4,KT
JRST FNDEV8 ;FLG T - RETURN N
GETCL 1,1
JUMPN 1,FNDEV5
CAMN 4,KNIL
JRST FNDEVD
POPN 1
FNDEVD: MOVEI 3,0 ;FOR INTERNAL CALLERS E.G. SETBLP
JRST FALSE ;NONE
FNDEV4: HRRZ 4,0(PP) ;FOUND ONE
CAMN 4,KT
JRST FNDEV6
CAMN 4,KNIL
JRST FNDEVC
SOSLE 0(CP) ;COUNT
JRST FNDEV7 ;NO ENUF
POPN 4 ;FLUSH NUM
FNDEVC: MOVEI 2,@2
HRRZ 3,0(2) ;RET PP PTR IN 2
EXCH 1,3 ;RET POS IN 3, FORM IN 1
RET
FNDEV6: AOS 0(CP) ;INCREM N
JRST FNDEV7
FNDEV8: POPN 1
JRST MKN
;BLIPSCAN(TYP IPOS) - FIND A FRAME CONTAINING A BLIP=TYP
BLPSCN: HRRZ 3,KNIL
CALL FNDEVL
JUMPE 3,FALSE ;NO SUCH
MOVEI 1,0(3)
JRST MKSTKP
;SETBLIP(TYP IPOS N VAL) - SET VALUE OF A BLIP
SETBLP: CALL FNDEVL
JUMPE 3,FALSE ;NOT FOUND
HRRZ 1,4(VP)
HRRM 1,0(2)
RET
U FNDEVT
;COPY STACK FROM A TO B (LINKS GO FROM B TO A)
;VALUE IS NEW B
CPYSTK: CALL STKGP
JUMPE 1,STKER1
CAMN 1,CF
MOVEI 1,0
MOVEM 1,CPYA
HRRZ 1,2(VP)
PUSH CP,[R] ;SO CAN CLOSE OUT CURRENT FRAME
CALL STKGP
JUMPE 1,STKER2
INTOFF
HRLM PP,0(CP) ;CLOSE OUT CURRENT FRAME
HRRZ 3,CF
SETCPO CP,3
HRRZM 3,CPYCF
MOVEM 1,CPYB
SKIPE 2,CPYA
JRST CPY6
MOVEI 2,0(3)
HRRZM 2,CPYA ;PUT CF BACK - CONT MOVE NOW
CPY6: HRRZM 2,CPYAA
SETOM CPYFLG
GETBIB 3,2 ;IS A'S BASIC FRAME ACTIVE?
JUMPN 3,CPY5 ;NOPE
GETAL 3,2 ;YES - MAKE CHAIN INACTIVE
MOVEM 3,CPYFLG
HRRZ 6,CF
JSYS SWCNTX ;UNWIND TO ALINK OF A
CPY5: JSP 7,REVLNK ;REVERSE LINKS
HRRZ 2,CPYB
GETCL 3,2 ;B NOW PTS TO OLD CLINK OF A
MOVEM 3,CPYT
MOVSI 4,1
JUMPE 3,CPY4 ;IF A NOT TOP
ADDM 4,USEWD(3) ;INCREM USE OF CLINK(A)
CPY4: HRRZ 1,CPYA ;NOW LINKED FORM A TO B
CPY3: HLRZ 2,NARWD(1) ;COMPUTE REAL LENGTH OF BASIC FRAME
TRZ 2,NARM1 ;FLUSH HI BIT
HRRZ 3,0(1)
MOVEI 3,1(3)
ADDI 2,0(3)
HLRE 5,PP
MOVN 5,5
JSYS PPCOP ;COPY BASIC FRAME - NEW IN 4
JRST PPFUL
EXCH 1,4
MOVEI 3,0(4)
JSP 7,ECOP ;COPY EXTENSION - NEW IN 3
MOVEI 2,1 ;MARK COPY INACTIVE
SETEIB 2,3
GETNAR 2,3 ;ECOP INCREMS CXT OF ORIG
ADD 2,0(3) ;... MUST UNDO THAT
MOVSI 4,-1
ADDM 4,1(2)
SUBI 1,1
SETBAS 1,3 ;NEW BASIC FRAME POINTER
HRLM PP,0(CP) ;SET PPO AND CPO
SETCPO CP,3
HRRZ 2,CPYT ;PUT CORRECT CLINK IN COPY
GETCL 4,3
GETAL 5,3
SETCL 2,3 ;NEW CLINK
CAIN 4,0(5)
JRST CPY7
MOVSI 2,1
ADDM 2,USEWD(5)
JRST CPY8
CPY7: SETAL 2,3 ;NEW ALINK ALSO IF ORIGINALLY =
CPY8: MOVEM 3,CPYT ;CURRENT BECOME S CLINK OF NEXT
HRRZ 2,CPYA
GETCL 1,2
HRRZM 1,CPYA
CAME 2,CPYB
JRST CPY3
HRRZ 1,CPYAA
HRRZ 2,CPYB
JSP 7,REVLNK ;RESTORE ORIG. LINKS
MOVEM CP,CF ;FLG NO CURRENT FRAME
HRRZ 1,CPYT ;...SO MKSTKP WONT BURP
HRROS USEWD(1) ;NEW STK PTR IS ONLY USE
CALL MKSTKP
HRRZ 3,CPYCF
SKIPL 6,CPYFLG
JSYS SWCNTX ;RETURN TO CURRENT CONTEXT
INTON
JRST PPRCR ;GO RETURN FROM COPYSTK
U CPYAA
U CPYA
U CPYB
U CPYT
U CPYCF
U CPYFLG
;REVERSE STACK LINKS FROM B IN 1 TO A IN 2
REVLNK: MOVEI 5,0(1) ;ORIGINAL B
GETCL 3,2 ;CLINK(A)=X - MAKE CLINK(B)=OLD CLINK(A)
CAIE 1,0(2) ;NOTHING TO DO IF ONLY ONE FRAME
REVL2: CAIN 3,0(2)
JRST 0(7)
JUMPE 1,REVL3 ;BAD - NEVER GET TO A FROM B
GETCL 4,1 ;CLINK(B)=Y
SETCL 3,1 ;NEW CLINK(B) = X
GETAL 6,1
CAIN 6,0(4)
SETAL 3,1 ;AND ALINK TOO IF ORIG =
MOVEI 3,0(1) ;X←B
MOVEI 1,0(4) ;B←Y
JRST REVL2
REVL3: EXCH 1,3
MOVEI 2,0(5) ;RE-REVERSE FROM CURRENT TO ORIG
JSP 7,REVL2
HRRZ 3,CPYCF
SKIPL 6,CPYFLG
JSYS SWCNTX ;REWIND TO CURRENT CONTEXT IF NECESSARY
INTON
ERROR0 23,R
; SETCLINK[POS;NEWFRAME;FLG]
; SMASHES THE CLINK OF POS TO BE NEWFRAME
; IF FLG=T THEN NEWFRAME IS RELEASE IFF POS IS RETURNED AS RESULT
STCL: CAMN 1,KNIL ;UNBOX FIRST ARG
HRROI 1,-1
CALL STKGP
JUMPE 1,STKER1
PUSH PP,1
HRRZ 1,2(VP) ;UNBOX 2ND ARG
CAMN 1,KNIL
HRROI 1,-1
CALL STKGP
MOVEI 2,0(1)
JUMPE 2,STKER2
MOVEI 4,0(2)
POP PP,1
STCL1: CAIN 4,0(1) ;SEARCH CLINK OF NEWFRAME
JRST FALSE ; TO SEE IF POS IS ON IT
GETCL 4,4
JUMPN 4,STCL1
INTOFF ;OK, NOW DO THE CHANGE
GETCL 4,1 ;GET OLD CLINK
SETCL 2,1 ;SET NEW CLINK
MOVSI 5,1
ADDM 5,USEWD(2) ;BUMP COUNT OF NEW FRAME
GETAL 2,1 ;GET ALINK OF POS
STAL0: CAIN 2,0(4) ;IS IT EQ TO THE OTHER LINK?
JRST STCL2 ;IF SO, IT IS AN "EASY" RETURN FRAME
MOVEI 2,(4)
CALL FLFRA ;FLUSH OLD FRAME
STCL4: INTON
HRRZ 1,2(VP)
HRRZ 2,3(VP)
CAME 2,KNIL ;RELEASE NEWFRAME?
CALL RELSTK ;YES
HRRZ 1,1(VP) ;RETURN POS TO INDICATE SUCCESS
RET
STCL2: MOVEI 2,PPRC ;SET TO "HARD" RETURN
SETFLG 2,1
JRST STCL4
; SETALINK[POS;NEWFRAME;FLG]
; SMASHES THE ALINK OF POS TO BE NEWFRAME
; IF FLG=T THEN NEWFRAME IS RELEASE IFF POS IS THE RESULT
STAL: CAMN 1,KNIL ;UNBOX FIRST ARG
HRROI 1,-1
CALL STKGP
JUMPE 1,STKER1
PUSH PP,1
HRRZ 1,2(VP) ;UNBOX 2ND ARG
CAMN 1,KNIL
HRROI 1,-1
CALL STKGP
MOVEI 2,0(1)
JUMPE 2,STKER2
MOVEI 4,0(2)
POP PP,1
SETZ 3,
STAL1: CAIN 4,0(1) ;SEARCH ALINK OF NEWFRAME
JRST FALSE ; TO SEE IF POS IS ON IT
JUMPN 3,STAL2 ;ALREADY HAVE AN ACTIVE FRAME?
MOVE 3,(4) ;NO CHECK THIS ONE
TLNN 3,SWPEIB
MOVEI 3,0(4) ;THIS IS ONE
STAL2: GETAL 4,4
JUMPN 4,STAL1
MOVEI 5,0(1) ;NOW FIND AN ACTIVE FRAME FROM POS
STAL3: GETAL 5,5
MOVE 6,0(5)
TLNE 6,SWPEIB
JRST STAL3
MOVEI 6,0(5) ;GOT IT, NOT CONTINUE TO SEE
STAL4: CAIN 6,0(3) ; WHO IS BELOW WHO
JRST STAL5 ;FOUND THE MATCH
GETAL 6,6
JUMPN 6,STAL4
MOVEI 3,0(5) ;DIDNT FIND IT
STAL5: HRRZ 6,CF ;3 HAS THE MAGIC POINT TO SWITCH TO
JSYS SWCNTX ;SWITCH TO THE MAGIC POINT
INTOFF ;OK, NOW DO THE CHANGE
GETAL 4,1 ;GET OLD ALINK
SETAL 2,1 ;SET NEW ALINK
MOVSI 5,1
ADDM 5,USEWD(2) ;BUMP COUNT OF NEW FRAME
EXCH 3,6
JSYS SWCNTX ;SWITCH BACK FROM MAGIC POINT
GETCL 2,1 ;GET CLINK OF POS
JRST STAL0
;BOX A STACK POINTER
MKSTK1: PUSH CP,1
MOVEI 1,STKPT
CALL GC1
POP CP,1
MKSTKP: CAMN 1,CF
JRST STKERR ;DONT BOX CF(HAVE TO COPY IT FIRST)
SKIPN 2,FRESTK
JRST MKSTK1 ;NO ROOM
INTOFF
MOVSI 3,1
ADDM 3,USEWD(1) ;INCREMENT USE
EXCH 1,0(2) ;STORE - GET NEW FREE
EXCH 1,FRESTK
INTON
RET
;MAKE A FRAME FOR FUNCTION FUNCTION
FUNCT1: STE 1,LIST
ERROR1 33,FUNCT1
PUSH CP,[0]
FUNCT2: STE 1,LIST
JRST FUNCT3
CDRA 2,1
CARA 1,1
STE 1,ATOM
ERROR1 33,FUNCT1
PUSH PP,2
PUSH PP,1
CALL EVAL
POP PP,2
GTVALC 2,2
HRLI 1,0(2)
EXCH 1,0(PP)
AOS 0(CP)
JRST FUNCT2
FUNCT3: INTOFF
MOVEI 1,MKSTKP
EXCH 1,0(CP)
MOVEI 5,0(PP)
SUBI 5,0(1)
HRLM 5,0(CP)
MOVEI 3,1(CP)
EXCH 3,CF
MOVSI 4,1
ADDM 4,USEWD(3) ;INCREM USE OLD CF
SETCPO CP,3
PUSH CP,5
PUSH CP,3 ;ALINK = OLD CF
PUSH CP,[0] ;CLINK = 0
PUSH CP,HCRETC
HRLM 1,-3(CP) ;# ARGS
PUSH PP,KFNARG
HRLM PP,-2(CP) ;SET PPI
PUSH CP,[R]
HRLM PP,0(CP) ;SET PPO
HRLM CP,-1(CP) ;SET CPO
HRRZ 1,CF
MOVEI 4,-1
SETUSE 4,1 ;SET USE = -1, MKSTKP WILL INCREM
MOVEI 2,1
SETEIB 2,1 ;MARK AS NON-CURRENT
SETBIB 2,1 ;AND AS DEEP BOUND
JRST PPRC31 ;GO RUN ORIGINAL FRAME
;ROUTINE TO DETERMINE TYPE OF ARGS FOR FUNCTION CALL
;CALLED WITH ATOM NAME IN AC1
;IF ATOM DOES NOT HAVE A LEGAL DEFINITION, RETURNS NO-SKIP
;OTHERWISE, RETURNS SKIP WITH BITS IN AC1, 34 AND 35
; 35=1 => NO-EVAL
; 34=1 => NO-SPREAD
ARGTYP: MOVE 2,1(1) ;GET DEFINITION
HLRZ 3,2 ;GET CALLING INSTRUCTION
LSH 3,-↑D9 ;RIGHT JUSTIFIED
CAIGE 3,HCCALV ;IS IT HCCAL
JRST .+3 ;NO
CAIG 3,HCCALV+3
JRST ARGT1 ;YES, FN IS SUBR
MOVEI 3,0(2) ;NO, GET DEFINITION POINTER
ARGTYB: CAMN 3,KNIL ;DEFINED?
RET ;NO, RETURN NO-SKIP
LDT 4,3 ;GET TYPE OF DEFINITION
CAIN 4,LISTT ;S-EXPRESSION?
JRST ARGT2 ;YES
CAIN 4,CCODET ;COMPILED CODE?
JRST ARGT3 ;YES
CAIE 4,HANDLT
RET ;ANYTHING ELSE IS ILLEGAL
ARGT0A: LSHC 1,↑D13 ;SWAPPED, GET BITS FROM AC FIELD
JRST ARGT3A
ARGT1: MOVEI 1,0(3) ;FN IS SUBR, GET BITS FROM INSTR.
ARGT3A: ANDI 1,3
AOS 0(CP) ;RETURN SKIPPING
RET
ARGT2: MOVEI 1,0 ;FN IS S-EXPRESSION
CARA 2,3
CAMN 2,KLAM ;LAMBDA?
JRST ARGT2A ;YES
CAME 2,KNLA ;NO, NLAMBDA?
JRST ARGT4
TRO 1,1 ;YES, MEANS NO-EVAL
ARGT2A: CDRA 3,3 ;GET VARIABLES
CARA 3,3
CAMN 3,KNIL
JRST RSKP
STE 3,LIST ;LIST?
TRO 1,2 ;NO, ATOM (ASSUMED) MEANS NO SPREAD
JRST RSKP ;RETURN AND SKIP
ARGT3: IFDEF MAXC,<
HLRZ 1,0(3)
MOVE 2,2(3)
ANDI 1,777000
CAIE 1,107000 ; BLISP instruction?
JRST ARGTC
LDB 1,[POINT 2,0(3),15]
TRCA 1,1
ARGTC:> HRRZ 1,1(3) ;FN IS COMPILED, GET TYPE FROM 2ND WD
JRST ARGT3A
ARGT4: CAME 2,KFNARG ;FUNARG?
RET ;NO ILLEGAL
CDRA 3,3
CARA 3,3 ;GET THE FUNCTIONAL PART
STN 3,LIST
JRST ARGT2 ; LIST -
STE 3,ATOM
RET ;NOT ATOM 0R LIST - ILLEGAL
MOVEI 1,0(3)
JRST ARGTYP
ARGTY: STE 1,ATOM
JRST ARGTYA
CALL ARGTYP ;USER FUNCTION ARGTYPE
JRST FALSE
JRST MKN
ARGTYA: CALL SUBRP ;ARG NOT ATOM - ASSUME DEF
HRRZ 3,1(VP)
CAME 1,KNIL
JRST ARGTYC
LDT 2,3
CAIN 2,HANDLT
JRST ARGTYH
CALL ARGTYB
JRST FALSE
JRST MKN
ARGTYC: CARA 1,3
SUBI 1,ASZ
LSH 1,-4
ADDI 1,ASZ
RET
ARGTYH: JSYS SWPFIX ;GET THE DAMN THING INTO MEMORY
HRLI BR,(3) ;AND GET ARGTYPE BITS A LA
CALL SWAPIN ;TWO PAGES BELOW AT PUTD5
IFDEF MAXC,<
LDB 1,[POINT 9,2(BR),8]
CAIE 1,107
JRST .+3
LDB 1,[POINT 2,2(BR),15]
TRCA 1,1
>
HRRZ 1,3(BR) ;HERE ARE THE BITS
SETZ BR,
JRST MKN
;GETD AND PUTD
GETD: STE 1,ATOM ;ATOM?
JRST FALSE ;NO - RET NIL
MOVE 2,1(1) ;GET DEF CELL
HLRZ 3,2 ;GET CALLING INSTRUCTION
LSH 3,-↑D9
CAIG 3,HCCALV+3 ;SUBR?
CAIGE 3,HCCALV
JRST GETD1 ;NO
LDB 1,[POINT 6,2,12] ;BITS - TYPE*16+#ARGS
ADDI 1,ASZ ;MAKE SMALL NUMBER
MOVEI 2,0(2) ;CODE ADDRESS
JRST CONS ;RETURN CONS OF TYPE INFO AND LOC
GETD1: MOVEI 1,0(2) ;NOT SUBR - RETURN POINTER
RET
PUTD: STE 1,ATOM
ERROR1 33,R
CAMN 2,KNIL
JRST PUTD2
LDT 3,2 ;GET TYPE OF DEF
CAIN 3,ATOMT ;ATOM?
JRST PUTDX ;YES, UNDEFINED
CAIN 3,HANDLT
JRST PUTD5
CAIE 3,CCODET ;COMPILED CODE?
JRST PUTD1 ;NO
HRLI 2,<PUSHJ CP,>B53 ;YES, INSERT CALLING INSTRUCTION
PUTD3: MOVEM 2,1(1) ;STORE IN FN CELL
PUTD4: MOVEI 1,0(2) ;RETURN DEF
RET
PUTD1: CAIE 3,LISTT ;LIST?
JRST PUTDX ;NO, UNDEFINED
CARA 3,2 ;YES
CAIG 3,ASZ+67
CAIGE 3,ASZ ;SUBR?
JRST PUTD2 ;NO, EXPR
SUBI 3,ASZ ;YES, GET ARG BITS
LSH 3,5
IORI 3,<HCCALV>B26 ;INSERT CALLING INSTRUCTION
HRLM 3,1(1)
CDRA 3,2 ;GET CODE LOC
CAMGE 3,ENDCOR ;CHECK FOR NON-DATA LOC
CAMG 3,BGNCOR
JRST .+2
JRST PUTD2 ;DATA, TREAT AS EXPR
HRRM 3,1(1)
JRST PUTD4
PUTD2: HLL 2,EVALUU ;USE EXCAL INSTRUCTION
JRST PUTD3
PUTD5: HRLI 2,<SBCAL 0,0>B53
JSYS SWPFIX
HRLZI BR,(2) ;LH(BR)=HANDLE FOR SWAPIN
CALL SWAPIN
IFDEF MAXC,<
LDB 3,[POINT 9,2(BR),8] ; Get opcode
CAIE 3,107 ; BLISP instruction?
JRST .+3
LDB 3,[POINT 2,2(BR),15] ; 1B34←no-spread bit, 1B35←eval bit
TRCA 3,1
>
HRRZ 3,3(BR) ;RH OF 1ST WD AFTER JSP TO ENTERF
DPB 3,[POINT 4,2,12] ;HAS THE BLOODY FNTYP BITS FOR SBCAL
SETZ BR,
JRST PUTD3
PUTDX: MOVEI 1,0(2) ;ERRONEOUS DEFINITION
ERROR1 33,R
;PREDICATES FOR FUNCTION TYPE, WORK GIVEN FN NAME OR DEF
CCODEP: LDT 2,1
CAIE 2,ATOMT ;ATOM?
JRST CCDP1 ;NO ASSUME GIVEN DEF
HRRZ 1,1(1) ;YES , GET DEF
LDT 2,1
CCDP1: CAIN 2,CCODET
JRST TRUE
JRST SCODP1
SUBRP: LDT 2,1
CAIE 2,ATOMT
JRST SUBRP1
HLRZ 1,1(1)
LSH 1,-↑D9
CAIG 1,HCCALV+3 ;HAND CODE CALL?
CAIGE 1,HCCALV
JRST FALSE
JRST TRUE
SUBRP1: CAIE 2,LISTT ;IS GETD A LIST?
JRST FALSE ;NO- FALSE
CARA 2,1
CAIG 2,ASZ+67 ;CAR BET. 0 AND 3 ?
CAIGE 2,ASZ
JRST FALSE ;NO - FALSE
CDRA 1,1
CAMGE 1,ENDCOR ;CDR NON-DATA ?
CAMGE 1,BGNCOR
JRST TRUE ;YES - IS SUBR
JRST FALSE
EXPRP: LDT 2,1
CAIE 2,ATOMT
JRST EXPRP1
MOVE 1,1(1)
XOR 1,EVALUU
TLNN 1,-1
CAMN 1,KNIL
JRST FALSE ;NOT EXPR, OR IS NIL
JRST TRUE
EXPRP1: CAIE 2,LISTT ;LIST?
JRST FALSE ;NO-FALSE
CALL SUBRP1
CAME 1,KNIL
JRST FALSE
JRST TRUE
SCODEP: LDT 2,1
CAIE 2,ATOMT
JRST SCODP1
HRRZ 1,1(1)
LDT 2,1
SCODP1: CAIN 2,HANDLT
JRST TRUE
JRST FALSE
;BASIC PREDICATES
ATOM: LDT TP,1
CAIL TP,ATOMT ;ATOM IS REALLY ATOM OR NUMBER
CAILE TP,SMALLT
JRST FALSE
JRST TRUE
LITATM: STE 1,ATOM
JRST FALSE
JRST TRUE
EQ: CAIE 1,0(2) ;LIKE COMPILED EQ
JRST FALSE
JRST TRUE
NULL: CAME 1,KNIL ;ALSO NOT
JRST FALSE
JRST TRUE
NUMBRP: LDT TP,1
CAIL TP,FLOATT ;FIXED, FLOATING, OR SMALL
CAILE TP,SMALLT
JRST FALSE
RET
LISTP: STE 1,LIST
JRST FALSE
RET
FLOATP: STE 1,FLOAT
JRST FALSE
RET
MINUSP: CALL GUNBOX
JUMPL 1,TRUE
JRST FALSE
STRNGP: STE 1,STPT
JRST FALSE
RET
HANDLP: STE 1,HANDL
JRST FALSE
RET
STKPP: STE 1,STKP
JRST FALSE
RET
VCELLP: STE 1,VCELL
JRST FALSE
RET
AND: MOVE 2,KT
AND1: CAMN 1,KNIL ;MORE CLAUSES?
JRST R2 ;NO, RETURN LAST VALUE
HRLI 1,PRBLIP
PUSH PP,1
CARA 1,1 ;NEXT CLAUSE
CALL EVAL
MOVEI 2,0(1)
POP PP,1
CAMN 2,KNIL ;NIL?
JRST FALSE ;YES, FAIL => RETURN NIL
CDRA 1,1 ;NO, CONTINUE
JRST AND1
OR:
OR1: CAMN 1,KNIL ;MORE CLAUSES
RET ;NO, FAIL
HRLI 1,PRBLIP
PUSH PP,1
CARA 1,1 ;NEXT CLAUSE
CALL EVAL
MOVEI 2,0(1)
POP PP,1
CAME 2,KNIL ;NIL?
JRST R2 ;NO, RETURN IT
CDRA 1,1 ;YES, CONTINUE
JRST OR1
IEQP: CALL I2UBOX
CAME 1,2
JRST FALSE
JRST TRUE
EQUAL: CAIN 1,0(2)
JRST TRUE
EQUAL2: LDT 3,1
CAIE 3,LISTT
JRST EQNLST
STE 2,LIST
JRST FALSE
HLRZ 3,0(1) ; CDR 1
HLRZ 4,0(2)
HRRZ 1,0(1)
HRRZ 2,0(2)
CAIN 3,0(4)
JRST EQUAL
PUSH PP,3
PUSH PP,4
CALL EQUAL
CAMN 1,KNIL
JRST URET2 ; pop args & return NIL
POP PP,1
POP PP,2
JRST EQUAL2
STREQU: LDT 3,1
CAIE 3,STPTT
JRST FALSE
STREQ1: STE 2,STPT
JRST FALSE
CALL UPATM
MOVE 5,3
MOVEI 6,0(4)
MOVE 1,2
CALL UPATM
CAIE 4,0(6)
JRST FALSE
JUMPE 4,TRUE
STREQ2: ILDB 1,3
ILDB 2,5
CAIE 1,0(2)
JRST FALSE
SOJG 4,STREQ2
JRST TRUE
EQNLST: CAIN 3,STPTT
JRST STREQ1
EQP: CAIN 1,0(2) ;EQ WHICH WORKS FOR NUMBERS TOO
JRST TRUE ;...AND STACK POINTERS
MOVEI 6,0(2)
CALL GUBS
EXCH 1,6 ;SAVE UNBOXED NUMBER
MOVEI 7,0(2) ;AND ITS TYPE
CALL GUBS ;UNBOX SECOND ARG
CAIN 2,0(7) ;BOTH SAME TYPE?
JRST EQPCV ;YES- COMPARE VALUES
CAIE 7,FLOATT ;NO- IS ONE ARG FLOATING?
JRST EQP1 ;CHECK OTHER ARG
EQP2: CALL FXFLT ;CONVERT FIXED TO FLOATING
JUMPN 2,FALSE ;IF SOMETHING LOST IN CONVERSION, FALSE
EQPCV: CAME 6,1
JRST FALSE
JRST TRUE
EQP1: CAIE 2,FLOATT
JRST EQPCV ;NEITHER ARG IS FLOATING
EXCH 1,6 ;GET FIXED ARG TO 1
JRST EQP2
GUBS: LDT 2,1
CAIN 2,SMALLT
JRST IUBS
CAIE 2,FLOATT
CAIN 2,FIXT
JRST IUB2 ;FIXED OR FLOAT, GET VALUE
CAIN 2,STKPT
JRST IUB2 ;STACK POINTER - GET VALUE
SUB CP,BHC+1 ;NOT NUMBER, FLUSH EXTRA RETURN
JRST FALSE ;AND RETURN FALSE
;BASIC SUBR'S
SET: PUSH PP,2 ;VALUE
JRST SET1
SETQ: CDRA 1,1 ;GET EXPR
CALL PROG1
PUSH PP,1
HRRZ 1,1(VP)
CARA 1,1 ;GET NAME
SET1: STE 1,ATOM ;ATOM?
ERROR1 16,R ;NO, ERROR
CAME 1,KT ;NAME IS T?
CAMN 1,KNIL ;NAME IS NIL?
CALL SETER0 ;YES, ILLEGAL TO SET NIL
GTVALC 2,1 ;GET VALUE CELL
SKIPN 2
CALL NEWVC1
POP PP,1
HRRM 1,0(2)
RET
SETER0: MOVE 2,0(PP)
SETERR: CAMN 1,2 ; OK TO SET NIL TO NIL OR T TO T
RET
ERROR1 6,R
SETN: STE 1,ATOM
ERROR1 16,R ;NON ATOMIC ARG
CAME 1,KT
CAMN 1,KNIL
CALL SETERR ; CAN'T SETN NIL EITHER
GTVALC 2,1 ;GET VALUE CELL
SKIPN 2
CALL NEWVC1
PUSH PP,2 ;SAVE BINDING LOC (OK. IS BAS. FR.)
HRRZ 1,2(VP)
CALL EVAL
CALL GUNBOX
PSETN @0(PP)
SUB PP,BHC+1
RET
;CONTROL SUBR'S
DDTC: HALTF
RET
OFFINT: CLRICH
RET
LOGOUT: CALL OFFINT
HALTF
LOGRE: SETICH
CALL SETMOD
JRST FALSE
CONSCF: CAME 1,KNIL
JRST CONSCN
MOVE 1,CNSCNT
JRST MKN
CONSCN: CALL IUNBOX
MOVEM 1,CNSCNT
HRRZ 1,1(VP)
RET
;BOXCOUNT(TYPE NEWCOUNT)
BOXCNT: CAME 2,KNIL ;JUST GET CURRENT COUNT?
JRST BOXCN1 ;NO
HRRZ 2,1(VP) ;YES - GET TYPE
MOVE 1,IBOXCN ;GET PROPER COUNTER
CAME 2,KNIL
MOVE 1,FBOXCN
CAIGE 1,MSN/2 ;DON'T COUNT THE BOXING OPERATION
CAMG 1,[-MSN/2]
SOS IBOXCN
JRST MKN
BOXCN1: MOVEI 1,0(2) ;GET THE NEW COUNT
CALL IUNBOX
HRRZ 2,1(VP) ;GET TYPE
MOVEI 3,IBOXCN ;GET THE PROPER COUNTER
CAME 2,KNIL
MOVEI 3,FBOXCN
MOVEM 1,0(3)
HRRZ 1,2(VP) ;RETURN THE NEW COUNT
RET
;RECLAIM AND MINFS
RECLM: CAMN 1,KNIL
SKIPA 1,[LISTT]
CALL IUNBOX
ANDI 1,MTYPN ;ARG IS TYPE
SKIPN TYPBLK(1)
JRST FALSE ;NO SUCH TYPE
PUSH CP,1
PUSH CP,[RECLM1]
CAIN 1,ARRAYT
JRST ARRGC
CAIN 1,STRNGT
JRST STRGC
JRST GC1
RECLM1: POP CP,1
HRRZ 1,TYPBLK(1)
MOVE 1,TNFR(1)
JRST MKN
MINFS: MOVEI 1,0(2)
CAMN 1,KNIL ;SECOND ARG NIL MEANS LIST
SKIPA 1,[LISTT]
CALL IUNBOX ;ELSE TYPE NUMBER
ANDI 1,MTYPN
HRRZ 2,TYPBLK(1)
JUMPE 2,FALSE
PUSHN 2
HRRZ 1,1(VP)
CAMN 1,KNIL
SKIPA 1,TMIN(2)
CALL IUNBOX
POPN 2
CAIGE 1,↑D25 ;AT LARRY'S SUGGESTION
MOVEI 1,↑D25
EXCH 1,TMIN(2)
JRST MKN
;OPENR/CLOSER
OPENR: CALL IUNBOX
MOVE 1,0(1)
JRST MKN
CLOSER: CALL IUNBOX ;ADDRESS
PUSHN 1
HRRZ 1,2(VP)
CALL GUNBOX ;CONTENTS
POPN 7
MOVEM 1,0(7)
HRRZ 1,2(VP)
RET
;MAP INDEF NUMBER OF ARGS
;COUNT OF ARGS SUPPLIED IN AC1
;INSTRUCTION TO EXECUTE TO PROCESS EACH ARG FOLLOWS CALL
MPARG: MOVN 7,1
JUMPGE 7,RSKP ;NO ARGS
HRLI 7,-1(7)
HRRI 7,0(VP)
JRST MPARG1
PLUS1: PUSHN 7
HRRZ 1,0(7) ;GET ARG
XCT @-2(CP) ;CALL EXECUTION FUNCTION
POPN 7
MPARG1: AOBJN 7,PLUS1
JRST RSKP
;NTYP - GET TYPE OF ARG
NTYP: LDT 1,1
JRST MKN
; TYPENAME returns name of datum
TYNAME: LDT 2,1
CAIE 2,1 ; arrays are special
JRST TYNARR
PUSH PP,1 ; save original array
CALL FBA ; look for beginning
POP PP,2
CAIE 1,0(2) ; beginning of array?
JRST TYNAR1 ; no
SKIPL 0(1) ; negative means hash array
JRST .+3
HRRZ 1,KHARRP
RET
CALL CKRDTS ; READ TABLE?
JRST .+3
HRRZ 1,KRDTBP
RET
CALL CKTRMT ; TERM TABLE?
SKIPA 1,KARRAP
HRRZ 1,KTRMTP
RET
; pointer into array space not beginning of array
TYNAR1: CAIE 2,2(1) ; pointer to word 2?
SKIPA 2,[1] ; no, use entry in type name table
SKIPA 1,KCCODP ; pointer to 2nd word -- assume CCODE
TYNARR: HLRZ 1,TYPNAM(2)
JUMPN 1,R
MOVEI 1,ASZ(2) ; no entry in table; return type number
RET
;NCONC
NCONC: MOVE 5,KNIL
CALL MPARG
CALL NCONC3
MOVE 1,5
RET
NCONC3: STE 5,LIST
JRST NCONC1
SKIPA
NCONC2: MOVEI 4,0(3)
CDRA 3,4
STN 3,LIST
JRST NCONC2
HRLM 1,0(4)
RET
NCONC1: MOVEI 5,0(1)
MOVEI 4,0(1)
RET
;FMEMB
FMEMB: HRRZ 3,0(2)
CAIN 3,0(1)
JRST FMEMBE
HLRZ 2,0(2)
CAME 2,KNIL
JRST FMEMB
FMEMBE: MOVEI 1,0(2)
RET
;MAKE HANDLE
MKHDL1: PUSHN 1
MOVEI 1,HANDLT
CALL GC1
POPN 1
MKHDL: SKIPN 2,FREHDL
JRST MKHDL1 ;NO SPACE
EXCH 1,0(2)
EXCH 1,FREHDL
RET
UMKHDL: CALL IUNBOX
JRST MKHDL
;INTEGER ARITHMETIC FUNCTIONS
MINUS: CALL GUNBOX
MOVN 1,1
JRST GBOX
;IPLUS
IPLUS: PUSHN [0] ;INITIAL SUM
CALL MPARG ;MAP ALL ARGS
CALL PLUS2 ;WITH PLUS2
ITMS1: POPN 1 ;ACCUMULATED VALUE
JRST MKN
PLUS2: CALL IUNBOX
ADDM 1,-4(CP) ;STACK HAS FLG,INIT,RET,FLG,TEM
RET
ITIMES: PUSHN [1] ;INITIAL PRODUCT
CALL MPARG
CALL ITMS2
JRST ITMS1
ITMS2: CALL IUNBOX
IMULM 1,-4(CP)
RET
LOGOR: PUSHN [0]
CALL MPARG
CALL LOGOR1
JRST ITMS1
LOGOR1: CALL IUNBOX
IORM 1,-4(CP)
RET
LOGAND: PUSHN [-1]
CALL MPARG
CALL LOGAN1
JRST ITMS1
LOGAN1: CALL IUNBOX
ANDM 1,-4(CP)
RET
LOGXOR: PUSHN [0]
CALL MPARG
CALL LOGXR1
JRST ITMS1
LOGXR1: CALL IUNBOX
XORM 1,-4(CP)
RET
LSHFT: CALL I2UBOX ;LOGICAL SHIFT
LSH 1,0(2)
JRST MKN
ASHFT: CALL I2UBOX ;ARITHMETIC SHIFT
ASH 1,0(2)
JRST MKN
;GENERAL PLUS
PLUS: CALL HIGHT
JRST IPLUS
FPLUS: PUSHN [0] ;FLOATING PLUS
CALL MPARG
CALL FPLUS2
FPLUS1: POPN 1
JRST MKFN
FPLUS2: CALL FUNBOX
FADRM 1,-4(CP)
RET
;UNBOX NUMBER TO FLOATING
FUNBOX: CALL GUNBOX ;UNBOX NUMBER
CAIN 2,FLOATT ;FLOATING?
RET ;YES- RETURN
FXFLT: IDIVI 1,400 ;FIXED TO FLOAT CONVERSION
FSC 1,243
FSC 2,233
FADL 1,2 ;LEAVE LOST PART IF ANY IN 2
RET
;FIND MOST COMPLICATED TYPE IN ARG LIST, SKIP IF FLOATING
HIGHT: PUSH CP,1 ;SAVE NUMBER OF ARGS
MOVEI 5,SMALLT
CALL MPARG
CALL HGH1
CAIN 5,FLOATT
AOS -1(CP)
POP CP,1
RET
HGH1: LDT 2,1
CAIGE 2,0(5)
MOVEI 5,0(2) ;LOW TYPE NUMS ARE MOST COMPLEX
RET
;GENERAL TIMES
TIMES: CALL HIGHT
JRST ITIMES
;FLOATING TIMES
FTIMES: MOVSI 5,201400 ;1.0
PUSHN 5
CALL MPARG
CALL FTIME2
JRST FPLUS1
FTIME2: CALL FUNBOX
FMPRM 1,-4(CP)
RET
;UNBOX NUMBERS IN 1 AND 2 TO HIGHEST TYPE, RESULTS IN 1 AND 2
;SKIP IF FLOATING
G2UBOX: LDT 4,2
LDT 3,1
CAIE 4,FLOATT
CAIN 3,FLOATT
JRST U2B1 ;AT LEAST ONE IS FLOATING
I2UBOX: PUSH PP,2 ;UNBOX 1 AND 2 TO INTEGER
CALL IUNBOX
POP PP,2
PUSHN 1
MOVE 1,2
CALL IUNBOX
U2B2: MOVE 2,1
POPN 1
RET
U2B1: AOS 0(CP)
F2UBOX: PUSH PP,2 ;UNBOX 1 AND 2 TO FLOATING
CALL FUNBOX
POP PP,2
PUSHN 1
MOVE 1,2
CALL FUNBOX
JRST U2B2
;CONVERT NUMBER IN 1 TYPE IN 2, TO TYPE IN 3
CNVNUM: CAIN 3,SMALLT
MOVEI 3,FIXT
CAIN 2,SMALLT
MOVEI 2,FIXT
CAIN 3,0(2)
RET
CAIE 3,FLOATT
JRST FLTFX
JRST FXFLT ;FIXED TO FLOAT
;GREATERP- GENERAL
GRTRP: CALL G2UBOX
JFCL 0
GRTR1: CAMG 1,2
JRST FALSE
JRST TRUE
;GREATERP- INTEGER
IGRTRP: CALL I2UBOX
JRST GRTR1
;GREATERP - FLOATING
FGTP: CALL F2UBOX
JRST GRTR1
;QUOTIENT- GENERAL
QTENT: CALL G2UBOX
JRST IQT1
JRST FQT1
;REMAINDER- GENERAL
RMNDR: CALL G2UBOX
JRST IRMND1
JRST FRMND1
;INTEGER QUOTIENT
IQTENT: CALL I2UBOX
IQT1: IDIV 1,2
JRST MKN
;INTEGER REMAINDER
IRMNDR: CALL I2UBOX
IRMND1: IDIV 1,2
MOVE 1,2
JRST MKN
;FLOATING QUOTIENT
FQTENT: CALL F2UBOX
FQT1: FDVR 1,2
JRST MKFN
;FLOATING REMAINDER
FRMNDR: CALL F2UBOX
FRMND1: MOVE 3,1
MOVE 4,2
FDVR 1,2
CALL FLTFX
CALL FXFLT
FMPR 1,4
EXCH 1,3
FSBR 1,3
JRST MKFN
;PROGN (EVAL LIST OF FORMS)
PROGN: MOVE 2,1
PROGN1: STE 2,LIST ;END OF LIST?
RET ;YES
CARA 1,2 ;NO, GET NEXT FORM
HRLI 2,PRBLIP
PUSH PP,2 ;SAVE REMAINDER OF LIST
CALL EVAL
POP PP,2
CDRA 2,2 ;GET REST OF LIST
JRST PROGN1
;VERY BASIC SUBR'S
CAR: CARA 1,1
RET
CDR: CDRA 1,1
RET
RPLACA: CAMN 1,KNIL
JRST RPLNIL
HRRM 2,0(1)
RET
RPLACD: CAMN 1,KNIL
JRST RPLNIL
HRLM 2,0(1)
RET
RPLNIL: CAMN 2,KNIL ;RPLAC(A-D) NIL NOT PERMITTED
RET ;EXCEPT WITH NIL
MOVEI 1,0(2)
ERROR1 7,R
;PROG1 (EVAL A LIST OF FORMS AND RETURN THE FIRST ONE)
PROG1: STE 1,LIST
RET ;YES
PUSH PP,1 ;SAVE ARG LIST
CARA 1,1 ;GET FIRST FORM
CALL EVAL ;EVAL FIRST FORM
HRLI 1,AVBLIP ;FOR WARREN
EXCH 1,(PP) ;GET REST OF LIST AND SAVE FIRST RESULT
CDRA 1,1 ;CAN'T DO CDR BEFORE 'CAUSE OF DWIM
CALL PROGN ;EVAL REST OF LIST
POP PP,1 ;RETURN THE FIRST ITEM
MOVEI 1,0(1) ;CLEAR OUT WARREN'S BLIP
RET
;COND
COND:
COND2: STE 1,LIST ;END OF CLAUSES?
RET ;YES, RETURN NIL
HRLI 1,PRBLIP
PUSH PP,1 ;SAVE LIST
CARA 1,1 ;GET PREDICATE
STE 1,LIST ;MAKE SURE CLAUSE LOOKS GOOD
RET
CARA 1,1
CALL EVAL
POP PP,2
CAMN 1,KNIL ;TEST
JRST COND1 ;FAILS, GET NEXT CLAUSE
CARA 2,2 ;GET REMAINDER OF CLAUSE
CDRA 2,2
JRST PROGN1 ;GO EVAL CONSEQUENCES
COND1: CDRA 1,2 ;GET NEXT CLAUSE
JRST COND2
;PROG, GO, RETURN
PROG: CARA 1,1 ;GET VARIABLE LIST
PRO1: STE 1,LIST ;ANY VARIABLES LEFT?
JRST PRO11
CARA 3,1 ;GET A VARIABLE
STE 3,LIST ;LIST?
JRST PRO14 ;NO- DO SIMPLE CASE
PUSH PP,1 ;SAVE ARG LIST
CARA 1,3 ;MAKE SURE NAME IS A LITAOTM
STE 1,ATOM
ERROR1 16,R
CAME 1,KNIL ;CHECK FOR NIL
CAMN 1,KT ;OR T
ERROR1 43,R ;IF SO, ERROR
CDRA 1,3 ;GET VALUE
CALL PROG1 ;EVAL SUCH THAT WARREN CAN GET TO IT
EXCH 1,0(PP) ;SAVE VALUE - GET BACK ARGLIST
PRO15: CDRA 1,1
JRST PRO1
PRO14: STE 3,ATOM ;MAKE SURE NAME IS A LITATOM
ERROR1 16,R
CAME 3,KNIL ;CHECK FOR NIL
CAMN 3,KT ;OR T
ERROR1 43,R ;IF SO, GIVE ERROR
PUSH PP,KNIL ;VALUE NIL
JRST PRO15
PRO11: HRRZ 3,CF ;ARGS ALL DONE - FUDGE FRAME
GETPPI 2,3 ;BEG TEMS -1
MOVEI 1,0(PP)
SUBI 1,0(2) ;# ARGS
MOVEI 2,PROGC-1 ;FAKE FN NAME
PUSHJ CP,EFNCAL
POPJ CP,
PROGC: PUSHJ CP,.+1
HRLM 1,-3(CP)
PUSH PP,KPRGLM ;FAKE FN NAME
HRLM PP,-2(CP)
HRRZ 2,CF
GETCL 2,2 ;PRIOR FRAME
GETBAS 2,2
HRRZ 2,1(2) ;WHOL PROG
CARA 4,2 ;ARG LIST
MOVEI 3,0(VP)
PRO13: STE 4,LIST ;ANY MORE ARG LIST?
JRST PRO12 ;NOPE
CARA 1,4
STN 1,LIST
CARA 1,1 ;LIST - GET CAR
GTVALC 2,1
SKIPN 2 ;VALUE CELL EXISTS?
CALL NEWVC1 ;NO - GET IT
BINDIT 2,1(3),5 ;BIND ARG
CDRA 4,4
AOJA 3,PRO13
PRO12: HRRZ 2,CF
GETCL 2,2 ;PRIOR FRAME
GETBAS 2,2
HRRZ 2,1(2) ;CONTAINS WHOLE PROG
HRRZ VP,-3(CP)
PRO3: CDRA 2,2
CAMN 2,KNIL
JRST R2 ;DONE - RETURN NIL
HRLI 2,PRBLIP
PUSH PP,2 ;CURRENT STATE OF PROG
CARA 1,2 ;GET A STATEMENT
STE 1,ATOM ;LABEL?
CALL EVAL ;NO - EVAL IT
POP PP,2 ;GET BACK PROG
JRST PRO3
GO: CARA 1,1 ;GET GO LABEL
MOVEM 1,PROT1 ;SAVE IT
HRRZ 3,CF ;GET CURRENT FRAME
CALL FPROG ;FIND FIRST PROG
JRST PROGER ;NOPE
GO2: MOVEI 4,(1)
GETCL 2,1 ;PRIOR FRAME
GETNAR 3,2 ;GET THE FN NAME
ADD 3,(2)
HRRZ 3,1(3)
HRRZ 3,1(3) ;GET FN DEF
CAIE 3,PROG ;IS IT A REAL PROG?
JRST GO3 ;NO.
GETBAS 2,2 ;...FIRST ARG
HRRZ 2,1(2) ;...IS WHOLE PROG
HRRZ 1,PROT1 ;THE LABEL
GO1: CDRA 2,2
CAMN 2,KNIL ;ANY STATEMENTS LEFT?
JRST GO3 ;NO, UNDEFINED LABEL
CARA 3,2
CAIN 3,0(1) ;IS THIS DESIRED LABEL?
JRST GOR ;YES, CONTINUE WITH PROG
JRST GO1 ;NO, CONTINUE SEARCH
GO3: MOVEI 3,0(4) ;TRY HIGHER PROG
GETCL 3,3
CALL FPROG
JRST PROGER ;NOPE
;*** GETCL 2,1
;*** GETBAS 2,2
;*** HRRZ 2,1(2) ;THIS WHOL PROG
;*** PUSH PP,1 ;SAVE THIS FRAME
;*** HRRZ 1,CF
;*** GETCL 1,1
;*** GETBAS 1,1
;*** HRRZ 1,1(1) ;PRIOR PROG
;*** CALL MM ;WAS IT INNER?
;*** CAMN 1,KNIL
;*** JRST PROGE1
;*** POP PP,1 ;YES
JRST GO2
PROGE1: POP PP,1
PROGER: HRRZ 1,PROT1
ERROR1 10,RESET
U PROT1
GOR: HRRZM 2,PROT1
MOVEI 1,(4)
INTOFF
JSP 7,UNSTK ;FLUSH TO IT
HRRZM 1,CF ;THE PROG FRAME
GETCPO 4,1
HLRZ 2,0(4)
JSYS RECP
MOVEI 4,0(2)
JSYS REPP
INTON
HRRZ 1,PROT1
HRRZ 3,CF
GETUSE 4,3 ;SEE IF USE(PROG)>0
SOJL 4,GOR1
SETUSE 4,3 ;YES - DECR.
JSP 7,ECOP ;COPY PROG FRAME - SO CAN FUDGE IT
GOR1: MOVEI CP,FLGWD+1(3) ;FLUSH C-TEMS BACK TO FLG+1
HRLI CP,@ICPC
SETCPO CP,3 ;AND SET CPO TO SHOW IT
GETPPI PP,3 ;NOW FLUSH P-TEMS
HRLI PP,@IPPC
MOVEI 2,0(PP)
HRLI 2,PRORR
MOVSM 2,FLGWD+1(3) ;FIX REAL RET. AND PPO
JRST PPRCR ;AND GO RUN THE PROG
PRORR: MOVEI 2,0(1) ;GET HERE
JRST PRO3
RETURN: HRRZ 3,CF
CALL FPROG ;FIND A PROG
RETU3: ERROR1 3,RESET ;NONE
HRRZ 2,1(VP) ;THE VALUE
GETCL 3,1 ;BACK UP ONE FRAME
GETNAR 4,3
ADD 4,0(3)
HRRZ 4,1(4) ;GET THE NAME
HRRZ 4,1(4) ;GET THE ACTUAL FN DEF
CAIE 4,PROG ;IS IT REALL A PROG?
JRST RETURN+1 ;NO, TRY AGAIN.
;I HAD TO ACTUALLY CHECK THE FN DEF OF THE FRAME NAME
;BECAUSE WT DOES A MOVD(PROG ADV-PROG)
RETU2: GETCL 1,1 ;BACK UP ONE FRAME
JUMPE 1,RETU3 ;SOMETHING FOULED
INTOFF
JRST RETT3 ;GO INTO RETTO
;FIND A PROG, 3 HAS ATARTING FRAME - RET FOUND FR. IN 1
;SKIP IF FOUND
FPROG: MOVE 1,KPRGLM
MOVNI 2,1
CALL STKPOS
SKIPE 1
AOS 0(CP)
RET
;FOR INTERNAL USE - RELEASE STACK BACK TO POS(UNBOXED)
;1 HAS PLACE TO RELEASE TO(PRESERVED), 2 HAS RANDOM VALUE TO SAVE
;CALLED WITH JSP 7,
;NOTE THAT THERE IS A BUG HERE IF THE FIRST PUSH CAUSES CF
;TO MOVE AND C(1) OR C(2) ARE CF -- I THINK THIS WONT
;HAPPEN BECAUSE NEVER CALLED WITHOUT PRIOR PUSHJ IN
;SAME FRAME GUARANTEEING SPACE FOR AT LEAST ONE PUSH
;TERMINAL INTERRUPTS SHOULD BE OFF
UNSTK: MOVEI 3,(1)
HRRZ 6,CF
JSYS SWCNTX ;UNWIND BINDINGS
UNSTK2: ;ENTER HERE FOR FLUSH ONLY (NO CONTEXT CHANGE)
PUSH CP,[XWD 0,R] ;CLOSE OUT CURRENT FRAME
JSYS SWPFIX
JSP 5,SWPFX2
HRRZ 4,CF
HRLM PP,0(CP) ;SET PPO
SETCPO CP,4 ;AND CPO
MOVSI 3,1
ADDM 3,USEWD(1) ;INCREM. USE(1) SO WILL STAY
MOVEM CP,CF ;FLG NO VALID FRAME
MOVEM PP,OPP ;IN CAS STACK OVERFLOW
PUSH PP,2 ;SAVE RANDOM VALUE
MOVEI 2,0(4) ;FROM CURRENT
CALL FLFR ;FLUSH(MAY OR MAY NOT DECR. USE)
POP PP,2 ;RESTORE RANDOM VALUE
JRST 0(7)
;FIXES UP A FRAME THAT MIGHT BE RUN NONLOCALLY - E.G.
;TARGET FRAME OF RETFROM, RETTO, RETURN, AND CPOS
;OF ENVEVAL AND ENVAPPLY
SWPFX2: CAMN 1,CF
JRST 0(5) ;IGNORE CURRENT FRAME
HRRZ TP,5(1) ;SWAPPED FRAME?
CAIN TP,SWPRET
JRST SWPFXA ;YES
CAIE TP,SWPRT2
JRST 0(5) ;NOT SWAPPED FRAME
SWPFXA: GETCPO TP,1
HRRZ 4,0(TP) ;GET REAL RETURN
CAILE TP,5(1) ; DOUBLE CHECK THAT FRAME REALLY SWAPPED
CAIN 4,BRREST ;ALREADY FIXED?
JRST 0(5)
HRLM 4,5(1) ;REAL RETURN TO SWPRET WORD
MOVEI 4,BRREST ;AND BRREST TO END OF FRAME
HRRM 4,0(TP)
JRST 0(5)
MM: CAIN 1,0(2)
POPJ CP,
STE 2,LIST
JRST FALSE
PUSH PP,2
HRLM 1,0(PP)
CARA 2,2
CALL MM
POP PP,2
CAME 1,KNIL
RET
HLRZ 1,2
CDRA 2,2
JRST MM
; INTERUPTABLE(FLG)
EBINT: CAME 1,KNIL ;TURN OFF INTERRUPTS?
JRST EBIN2 ;NO
EBIN1: HRRZ 1,KNIL ;YES
SKIPL NOFLG ;ALREADY OFF?
RET ;YES
HRRZ 1,KT ;NO - TURN THEM OFF
INTOFF
SETOM UNOFLG
RET
EBIN2: HRRZ 1,KT ;TURN ON INTERRUPTS
SKIPGE NOFLG ;ALREADY ON?
RET ;YES
HRRZ 1,KNIL ;NO
SETZM UNOFLG
INTON ;TURN THEM ON
RET
;INTERRUPTABLEP()
INTP: HRRZ 1,KNIL
SKIPGE NOFLG
HRRZ 1,KT
RET
U UNOFLG ;-1 IF USER HAS TURNED OFF INTERRUPTS
;FOR COMPILED PROG RETURNS OUT OF OPEN LAMBDAS
NLRET: PUSH PP,1
MOVE 1,2
HRRZ 2,CF
CALL STKNTH
POP PP,2
JRST RETU2
;FOR COMPILED PROG - NON-LOCAL GO'S
;MOVEI 2,# PTEMS TO SAVE MOVNI 1,N PUSHJ CP,NLGO
; ITEM IN AC 2 COULD ALSO BE -1-# PTEMS TO FLUSH
NLGO: HRLM 2,0(CP)
HRRZ 2,CF
CALL STKNTH
POP CP,2
INTOFF
MOVEM BR,NLGOT ;SAVE BR FOR POSSIBLE KLUDGE LATER
JSP 7,UNSTK
HRRZM 1,CF
EXCH 1,2
GETCPO 4,2
HLRZ 3,0(4)
JSYS RECP
MOVEI 4,0(3)
JSYS REPP
MOVEI 3,0(2)
GETUSE 4,3
SOJL 4,NLGO1
SETUSE 4,3
JSP 7,ECOP
NLGO1: HRRZ 2,FLGWD+2(3)
CAIN 2,SWPRT2
JRST NLGO4
CAIE 2,SWPRET ;SWAPPED FRAME?
JRST NLGO2
NLGO4: HRRZ 2,0(CP) ;YES
CAIE 2,BRREST ;GOTTA RESTORE?
JRST NLGO3 ;NOPE (SUSPECT ALWAYS HAVE TO)
MOVS 2,FLGWD+1(3) ;BR OF PROG FRAME
SUB 2,NLGOT ;BR OF LOWER PROG
ADDI 2,0(1) ;GET RET INTO CONTEXT OF TARGET PROG
HRLM 2,FLGWD+2(3) ;REPLACE REAL RETURN
HRRI 1,BRREST ;GO TO BRREST FIRST
NLGO3: MOVEI CP,FLGWD+2(3)
SKIPA
NLGO2: MOVEI CP,FLGWD(3) ;DELETE C-TEMS
HRLI CP,@ICPC
HLRE 2,1 ;# PTEMS TO SAVE OR FLUSH
JUMPL 2,NLGO5 ;JUMP IF IS # TO FLUSH
GETPPI PP,3
ADDI PP,0(2)
NLGO6: HRLI PP,@IPPC
INTON
HRRZ VP,0(3)
JRST 0(1)
NLGO5: XOR 2,[-1] ;AC2=|AC2|-1
GETPPO PP,3
SUBI PP,0(2)
JRST NLGO6
U NLGOT
;SET FREBRK
GCTRP: CAMN 1,KNIL
JRST GCTR1 ;ARG NIL - RET FREE COUNT
CALL IUNBOX
EXCH 1,FREBRK
JRST MKN
GCTR1: MOVE 1,FRECNT
JRST MKN
; SET GC MESSAGES
GCMESS: CAILE 1,ASZ
CAILE 1,ASZ+7
ERROR1 33,GCMESS
CAMN 2,KNIL
MOVEI 2,0
EXCH 2,GCMES1-1-ASZ(1)
SKIPN 1,2
MOVE 1,KNIL
RET
;TIGHTGC(FLG) - IF FLG IS T THEN GC WILL NOT ALLOCATE PAGES
; FOR ANY TYPE EXCEPT THAT BEING COLLECTED.
TGHTGC: CAMN 1,KNIL
JRST [ SETZ 1,
JRST THTGC2 ]
SETO 1,
THTGC2: EXCH 1,TITEGC
JUMPE 1,FALSE
JRST TRUE
U TITEGC
; SET FLAG FOR HERALD
HERALD: CAMN 1,KNIL
SETZ 1,
EXCH 1,HLDMSG
JUMPE 1,FALSE
RET
;MAP ON ALL ATOMS
MPATMS: HRRZ 1,NHP ;# HASH TABLE PAGES
MOVEM 1,ATMTT
MAPA3: HRRZ 3,ATOMHT(1)
MOVEI 4,MPS
HRLI 3,4 ;ATOMHT(4)
MAPA2: MOVE 1,@3
TLNN 1,777776
JRST MAPA1
MOVEI 1,-2(1)
PUSHN 3
PUSHN 4
PUSH PP,1(VP) ;FN
PUSH PP,1
LCALL KAPP.,2
POPN 4
POPN 3
MAPA1: SOJGE 4,MAPA2
SOSLE 1,ATMTT
JRST MAPA3
JRST FALSE
;MAKE INTEGER NUMBER
MKN: CAIGE 1,MSN/2 ;TEST FOR SMALL NUMBER
CAMG 1,[-MSN/2]
JRST MKN1
ADDI 1,ASZ ;SMALL NUMBER 0
RET
MKN1: SKIPN 2,FREENM ;TEST FREE LIST
JRST MKN2 ;EMPTY
EXCH 1,0(2) ;NOT EMPTY, STORE NUMBER AND GET
EXCH 1,FREENM ;UPDATE FREE LIST
AOS IBOXCN ;UPDATE INTEGER BOX COUNT
RET
MKN2: PUSHN 1 ;SAVE NUMBER
CALL INTGC ;INITIATE GARBAGE COLLECTION
POPN 1
JRST MKN1 ;TRY AGAIN
;UNBOX NUMBER TO INTEGER
IUNBOX: CALL GUNBOX ;UNBOX NUMBER
CAIE 2,FLOATT ;FLOATING?
RET ;NO- RETURN
FLTFX: MULI 1,400 ;CONVERT FLOAT TO FIXED
TSC 1,1
EXCH 1,2
JUMPL 1,FLTFX1
ASH 1,-243(2)
RET
FLTFX1: MOVN 1,1
ASH 1,-243(2)
MOVN 1,1
RET
TRUE: MOVE 1,KT ;RETURN T
RET
FALSE: MOVE 1,KNIL ;RETURN NIL
RET
;GENERAL UNBOX- GET VALUE IN 1, TYPE IN 2
GUNBOX: LDT 2,1 ;GET TYPE TO 2
CAIN 2,SMALLT ;SMALL?
JRST IUBS
CAIL 2,FLOATT ;FLOATING OR FIXED?
CAILE 2,FIXT
ERROR1 12,GUNBOX ;NO - ERROR
IUB2: MOVE 1,0(1) ;YES- GET VALUE
RET
IUBS: SUBI 1,ASZ ;SMALL NUMBER ZERO
RET
;GENERAL BOX- GIVEN VALUE IN 1, TYPE IN 2, DO APPROPRIATE BOX
GBOX: CAIE 2,FLOATT
JRST MKN ;INTEGER
MKFN: SKIPN 2,FREEFL ;MAKE FLOATING NUMBER
JRST MKF1 ;NO SPACE
EXCH 1,0(2) ;STORE NUMBER
EXCH 1,FREEFL ;GET POINTER, UPDATE FREE
AOS FBOXCN ;UPDATE FLOATING BOX COUNT
RET
MKF1: PUSHN 1
MOVEI 1,FLOATT
CALL GC1
POPN 1
JRST MKFN
;ALLOCATE AN ELEMENT OF A USER DATA TYPE
;TYPE NUMBER IN AC
NALLOC: CAIL 1,MSYST+1+ASZ ;CHECK DATA TYPE NUMBER
CAIL 1,MTYPN+ASZ
ERROR1 41,NALLOC
MOVEI 4,-ASZ(1) ;SAVE TYPE NUMBER
ANDI 4,77
NALOC2: SKIPN 2,TYPBLK(4) ;GET TYPE ENTRY
ERROR1 41,NALLOC
SKIPN 1,TFRE(2) ;FREE LIST EMPTY?
JRST GCUSER ;YES
HRRZ 3,(1) ;GET ADDR OF NEXT POINT
MOVEM 3,TFRE(2) ;AND STORE IT
HLRZ 2,TSIZ(2) ;CLEAR THE ITEM!
SETZM 0(1) ;CLEAR FIRST WORD
CAIN 2,1 ;ONLY 1 WORD?
JRST NALOC1 ;YES
HRLI 3,0(1) ;SET UP BLT WORD
HRRI 3,1(1)
ADDI 2,-1(1) ;STOPPING ADDRESS
BLT 3,0(2) ;CLEAR THE REST OF THE ITEM
NALOC1: RET
GCUSER: MOVEI 1,0(4)
CALL GC1 ;RECLAIM
JRST NALOC2
;DEFINE A USER DATA TYPE
;NWRDS IN 1
;NPTRS IN 2
DEFTYP: CALL IUNBOX ;UNBOX ARGS
PUSHN 1
HRRZ 1,2(VP)
CALL IUNBOX
MOVE 2,1
POPN 3
SETZM 1,DEFNUM
MOVSI 1,377777
MOVEM 1,DEFDIF
SKIPLE 3 ;NPTRS GR 0?
SKIPGE 2 ;YES, NWORDS NEGATIVE?
ERROR0 33,DEFTYP ;YES
LSH 3,1
CAILE 2,0(3) ;WILL PTRS FIT IN NWRDS?
ERROR0 33,DEFTYP ;NO
LSH 3,-1
MOVE 1,[XWD MSYST-MTYPN+1,MSYST+1]
DEFTP3: SKIPN 4,TYPBLK(1) ;EMPTY?
JRST DEFTP2 ;YES - USE IT!
HLRZ 5,TYPSIZ(1) ;GET STATUS AND NUM OF PTRS.
CAIN 5,1 ;STILL IN USE?
JRST DEFTP4 ;YES
HRRZ 5,TYPSIZ(1)
CAIE 2,0(5) ;STILL EQUIVALENT?
JRST DEFTP4 ;NO
HLRZ 5,TSIZ(4) ;GET NUMBER OF WORDS
CAILE 3,0(5) ;FIT AS A SUBSET?
JRST DEFTP4 ;NO
CAML 3,DEFDIF ;BETTER FIT THAN BEFORE
JRST DEFTP4 ;NO
MOVEM 3,DEFDIF ;YES
HRRZM 1,DEFNUM
DEFTP4: AOBJN 1,DEFTP3 ;TRY AGAIN
SKIPN 1,DEFNUM ;NONE FREE - ANY RECLAIMED?
ERROR0 42,NALLOC1 ;NO - ERROR OUT
HRRZ 2,TYPSIZ(1) ;SET STATUS FLAG
HRLI 2,1
MOVEM 2,TYPSIZ(1)
JRST MKN
DEFTP2: MOVEI 1,0(1)
PUSHN 1 ;SAVE TYPE NUMBER
HRLM 3,TUSER ;SO GC KNOWS SIZE
HRLI 2,1 ;SET STATUS
MOVEM 2,TYPSIZ(1) ;SAVE SIZE INFO.
MOVEI 2,(1) ;SET UP TO CALL GCTBS
MOVEI 10,TUSER
IMULI 1,NTWN
MOVEI 7,USEBLK-<<MSYST+1>*NTWN>(1)
MOVEM 7,TYPBLK(2)
PUSHJ GP,GCTBS ;SET THE TYPE TABLES
POPN 1 ;RETURN TYPE NUMBER
JRST MKN
U DEFNUM
U DEFDIF
;GENERAL USER CONS
USRCNS: SKIPN 1
JRST .+5 ;NO ARGS
MOVEI 6,0(1) ;SAVE NUMBER OF ARGS
MOVEI 5,(PP)
SUBI 5,0(1) ;POINT TO ARGS
HRRZ 1,(5) ;GET TYPE NUMBER
CALL NALLOC ;GET AN ITEM
MOVE 10,[HRLM 3,(2)] ;SET UP STORING OPERATION
HRRZ 2,(5)
HRRZ 7,TYPSIZ-ASZ(2) ;GET NUMBER OF POINTERS
MOVEI 2,0(1)
USRC1: JUMPE 7,NALOC1 ;EXIT IF ALL PTRS FILLED
ADDI 5,1 ;BUMP ARG PTR
SUBI 6,1 ;DEC NUMBER OF ARGS LEFT
JUMPLE 6,USRC2 ;RAN OUT OF ARGS?
HRRZ 3,(5) ;NO
JRST .+2
USRC2: MOVE 3,KNIL ;YES - USE NIL
XCT 10 ;STORE THE DATA
TLC 10,44000 ;FLIP BETWEEN HRLM AND HRRM
TLNN 10,40000 ;BACK TO HRLM?
AOJ 2, ;YES - BUMP DATA PTR
SOJA 7,USRC1 ;DEC. NUMBER OF PTRS AND LOOP
;GET NUMBER OF POINTERS
GTNPTR: CAIL 1,MSYST+1+ASZ ;CHECK DATA TYPE NUMBER
CAIL 1,MTYPN+ASZ
ERROR1 41,GTNPTR
CALL IUNBOX
HRRZ 1,TYPSIZ(1)
JRST MKN
;GET NUMBER OF WORDS
GTNWRD: CAIL 1,MSYST+1+ASZ ;CHECK DATA TYPE NUMBER
CAIL 1,MTYPN+ASZ
ERROR1 41,GTNWRD
CALL IUNBOX
HRRZ 1,TYPBLK(1)
HLRZ 1,TSIZ(1)
JRST MKN
;SET TYPE STATUS
;NIL = RETURN CURRENT STATUS
;0 = FREE TYPE
;1 = IN USE
;2 = A DEALOCATED TYPE
TYPSTS: CAIL 1,MSYST+1+ASZ ;CHECK DATA TYPE NUMBER
CAIL 1,MTYPN+ASZ
ERROR1 41,TYPSTS
CAMN 2,KNIL
JRST TYSTS1
HRRZ 1,2(VP)
CALL IUNBOX
HRRZ 2,1(VP)
MOVE 3,TYPSIZ-ASZ(2)
HRLM 1,TYPSIZ-ASZ(2)
HLR 1,3
JRST MKN
TYSTS1: HLRZ 1,TYPSIZ-ASZ(1)
JRST MKN
;DEFEVAL - DEFINE THE EVALUATION FUNCTION FOR A GIVEN DATA TYPE
;ARG1 = THE NUMBER OF THE DATA TYPE (CANNOT BE LIST, ATOM, OR NUMBER)
;ARG2 = T OR EVAL => ITEM EVALS TO ITSELF (THE INITIAL SETTING)
; = NIL => DO NOT RESET THE EVALUATION FUNCTION
; = A FUNC. NAME => ARG2 WILL BE CALLED WHEN THIS TYPE IS EVAL'ED
;RETURNS: NIL IF THE TYPE NUMBER IS ILLEGAL
; THE PREVIOUS EVALUATION FUNCTION OR
; T IF THE TYPE CURRENTLY EVALS TO ITSELF.
DEFEVA: CALL IUNBOX ;UNBOX THE TYPE NUMBER
SKIPL 1 ;VALID TYPE?
CAIL 1,MTYPN
JRST DFEVA4 ;NO
HRRZ 3,EVATAB(1) ;YES - CAN USER EVAL THIS TYPE?
CAIN 3,-1
JRST DFEVA4 ;NO
SKIPN 3 ;YES - WAS EVALING TO SELF?
MOVE 3,KT ;YES - RETURN T
HRRZ 2,2(VP) ;NO - GET NEW EVAL FN.
CAMN 2,KNIL ;CHANGING THE EVAL. FN?
JRST DFEVA2 ;NO
CAME 2,KT ;YES - FN=T OR EVAL?
CAMN 2,KEVAL
SETZ 2, ;YES - SET TO ZERO
HRRM 2,EVATAB(1) ;NO - SAVE THE NEW FN.
DFEVA2: MOVEI 1,0(3) ;RETURN PREV. EVAL. FN.
RET
DFEVA4: HRRZ 1,1(VP)
ERROR1 41,R
;DEFPRINT - DEFINE THE PRINTING FUNCTION FOR A GIVEN DATA TYPE
;ARG1 = THE NUMBER OF THE DATA TYPE (CANNOT BE LIST, ATOM, OR NUMBER)
;ARG2 = T => PERFORM THE SYSTEM'S DEFAULT PRINTING FOR THIS TYPE
; = NIL => DO NOT RESET THE PRINTING FN, JUST RETURN THE CURRENT FN.
; = A FN NAME => ARG2 WILL BE CALEED WHEN THIS TYPED IS PRINTED.
;RETURNS: THE PREVIOUS PRINTING FN OR
; T IF THE DEFAULT IS CURRENTLY IN EFFECT.
DEFPRI: CALL IUNBOX ;UNBOX THE TYPE NUMBER
SKIPL 1 ;VALID TYPE?
CAIL 1,MTYPN
JRST DFEVA4 ;NO
HLRZ 3,EVATAB(1) ;YES - CAN USER PRINT THIS TYPE?
CAIN 3,-1
JRST DFEVA4 ;NO
SKIPN 3 ;YES - WAS SYS. DEFLT?
MOVE 3,KT ;YES - RETURN T
HRRZ 2,2(VP) ;NO - GET NEW PRINT FN.
CAMN 2,KNIL ;CHANGING THE PRINT FN?
JRST DFPRI2 ;NO
CAMN 2,KT ;YES - FN=T?
SETZ 2, ;YES - SET TO ZERO
HRLM 2,EVATAB(1) ;NO - SAVE THE NEW FN.
DFPRI2: MOVEI 1,(3)
RET
;ALLOCATE SPACE FOR ARRAY - ARG IS NUMBER OF WORDS
ALLOCA: CALL IUNBOX
ALLOC1: TLNN 1,-1
CAIG 1,1
JRST ALLOCE ;INSANE LENGTH
MOVEI 2,0(1)
ADD 1,FREEAR
CAMG 1,ENDAR
JRST ALLOC2
MOVEI 1,0(2) ;WON'T FIT, MUST GC
PUSHJ GP,ARRGC
MOVEI 1,0(2)
ADD 1,FREEAR
CAMLE 1,ENDAR
ERROR0 25,RESET ;STILL WONT FIT,GIVE UP
ALLOC2: EXCH 1,FREEAR
HRRZM 2,0(1) ;SET LENGTH
SETZM 1(1) ;SET GC PTR AND PTR PTR TO 0
MOVEI 3,0(1) ;CHECK FOR FIRST ARRAY THIS PAGE
LSH 3,-LPS
HRRZ 2,BTT(3)
CAIN 2,0
HRRM 1,BTT(3) ;YES, ENTER IN BTT
RET
ALLOCE: CALL MKN
ERROR1 33,RESET
;ELT(ARRAY POSITION)
ELT: PUSH PP,[1]
SKIPA
ELTD: PUSH PP,[0]
LDT 2,1 ;CHECK TYPE
CAIN 2,HANDLT ;SWAPPED?
JRST SWAPPD ;YES
CAIE 2,ARRAYT ;NO - BETTER BE AN ARRAY
ERROR1 34,RESET
MOVEI 3,0(1)
CALL FBA
CAIE 1,0(3)
ERROR1 34,RESET ;MUST BE ARRAY BEG.
ELT2: PUSH PP,1
HRRZ 1,2(VP) ;POSITION
CALL IUNBOX
POP PP,4 ;ARRAY POINTER
HRRZ 3,1(4)
MOVEI 2,0(1)
ADDI 4,1(1)
MOVE 1,0(4)
POP PP,4
CAILE 3,1(2)
JRST MKN
TRNN 4,1
HLRZ 1,1
MOVEI 1,0(1)
RET
SWAPPD: CALL RFNPOS ;SWAP IT IN
SUBI 1,2 ;POINT TO HEADER
JRST ELT2
;ARRAY(LENGTH,#UNBOXED,INIT)
ARRAY: CALL IUNBOX
ADDI 1,2
CALL ALLOC1 ;GET LENGTH+2 WORDS
PUSH PP,1 ;SAVE ARRAY ADDR
HRRZ 1,2(VP)
CAMN 1,KNIL
TRZN 1,-1 ;NIL MEANS 0
CALL IUNBOX
ADDI 1,2
POP PP,2 ;ARRAY POINTER
HRRM 1,1(2) ;SET RELATIVE LOC. OF POINTERS
CAML 1,0(2)
JRST R2 ;NO POINTERS TO INITIALIZE
ADDI 1,1(2)
HRLI 1,-1(1)
HRRZ 3,3(VP) ;INIT VAL FOR POINTERS
HRLI 3,0(3)
MOVEM 3,-1(1)
MOVEI 3,0(2)
ADD 3,0(2)
CAIE 3,0(1) ;EXACTLY ONE POINTER?
BLT 1,-1(3)
R2: MOVEI 1,0(2)
RET
;PREDICATE
ARRAYP: LDT 2,1
CAIE 2,ARRAYT
JRST FALSE
RET
;GET BLOCK OF UNMOVABLE STORAGE
;1 - NUMBER OF PAGES
GETBLK: CALL IUNBOX
PUSHN 1
JUMPLE 1,GETBE ;ERROR
MOVEI 5,0(1)
CALL MTPGS ;LOOK FOR EMPTY PAGES
JRST GETBE ;CANT FIND
MOVEI 1,0(4)
MOVN 2,0(CP)
MOVEM 4,0(CP)
HRLI 1,0(2)
MOVEI 3,BLOCKT
CALL CLRPG
MOVEM 3,TYPTAB(1)
AOBJN 1,.-2
POPN 1
LSH 1,LPS
RET ;RETURN ADDRESS OF FIRST PAGE
GETBE: HRRZ 1,1(VP)
ERROR1 35,RESET
;RELEASE A BLOCK 1 - ADDR OF BEGINNING, 2- NUMBER PAGES
RELBLK: MOVEI 1,0(2)
CALL IUNBOX
JUMPLE 1,RELBE
HRRZ 2,1(VP)
LSH 2,-LPS
MOVNI 3,0(1)
HRLI 2,0(3)
PUSHN 2
RELB1: HRRZ 1,TYPTAB(2) ;CHECK THAT PGS REALLY BLOCK
ANDI 1,77
CAIE 1,BLOCKT
JRST GETBE ;NOT BLOCK - ERROR
AOBJN 2,RELB1
POPN 2
SETZM TYPTAB(2)
AOBJN 2,.-1
HRRZ 1,2(VP) ;RET # PAGES
RET
RELBE: HRRZ 1,2(VP)
ERROR1 35,RESET
CLRHSH: PUSH PP,1
PUSH CP,[RPP]
CAME 1,KNIL
JRST CLHSH4
HRRZ 1,@KSYSHSH ;GET SYSHASH VALUE
CAMN 1,KNIL ;INITED YET?
RET ;NO, DO NOTHING
CLHSH4: STN 1,LIST
CARA 1,1
STE 1,ARRAY
ERROR1 34,CLHSH4
CLHSH2: HRROS 2,0(1) ;CLEAR COUNT, GET LENGTH
MOVEI 2,0(2)
CAIL 2,3
SETZM 2(1)
CAIG 2,3
RET ;NOTHING TO CLEAR
HRLZI 3,2(1)
HRRI 3,3(1)
ADDI 2,-1(1)
BLT 3,0(2)
HSHLMT: HRRZ 2,0(1) ; GET NEW ARRAYSIZE
SUBI 2,2
MOVEI 3,0(2)
LSH 3,-3 ;GET 1/8 OF SIZE
SUBI 3,0(2) ;COMPUTE -7/8 OF SIZE
LSH 3,1 ;SHIFT OUT A FLAG BIT
HRLM 3,0(1) ;STORE "FULL" COUNT
RET
; test if hash array
HARRAP: STN 1,ARRAY ; not array?
SKIPL 0(1) ; word 0 negative?
JRST FALSE
RET
; make a new hash table
HARRAY: CALL IUNBOX
HARRY1: CALL HSHADJ
ADDI 1,2 ;MAKE ARRAY SIZE INTO TOTAL LENGTH
CALL ALLOC1
MOVEI 2,2
MOVEM 2,1(1)
JRST CLHSH2
; entry from REHASH- 1 array 2 ptr 3 value
HSHENT: SETZM HENTO
PUSH PP,1
JRST HSHLK4
; user GETHASH- 1 ptr 2 array
GETHSH: EXCH 1,2
SETOM HENTO ; -1 FOR LOOKUP
JRST HSHLK1
; user PUTHASH- 1 ptr, 2 value, 3 array
PUTHSH: EXCH 1,3
EXCH 2,3
SETZM HENTO ; 0 FOR STORE
CAMN 3,KNIL
AOS HENTO ; 1 FOR DELETE
; hash lookup routine: array in 1, key in 2, value in 3
; HENTO -1 lookup, 0 insert, 1 delete, else saved value
HSHLK1: CAME 1,KNIL ; use SYSHASHARRAY?
JRST HSHLK3 ; no
HRRZ 1,@KSYSHSH
CAME 1,KNIL
JRST HSHLK3 ; already allocated
SKIPE HENTO ; storing?
JRST FALSE ; no, return NIL
PUSH PP,2
PUSH PP,3
MOVEI 1,NPS-1
CALL HARRY1
HRRM 1,@KSYSHSH
POP PP,3
POP PP,2
HSHLK3: PUSH PP,1
STN 1,LIST ; list?
CARA 1,1
STE 1,ARRAY
ERROR1 34,RESET
HSHLK4: PUSH PP,3 ; value
MOVEI 3,0(2) ; key
HRRZ 6,0(1) ; array length
IDIVI 3,-2(6) ; rel addr to probe in 4
ADDI 4,2(1) ; make probe absolute
ANDI 3,17 ; compute reprobe
MOVE 3,PRIMTB(3)
CAIL 3,-2(6) ; bigger than array?
MOVEI 3,1 ; yes, make reprobe 1
MOVEI 10,0(4) ; save first probe location
MOVEI 7,-1(6) ; save highest address
ADDI 7,(1)
; main loop. ac's contain:
; 1 has array
; 2 probe key.
; 3 has reprobe interval
; 4 has probe address
; 5 scratch
; 6 has array length
; 7 has end of array
; 10 has original probe address
; 0(pp) has value
; -1(pp) has original array
HSH1: HLRZ 5,0(4) ; key in table
CAIG 5,1
JRST HSHLKE ; empty or deleted slot
CAIE 5,0(2) ; used - right one?
JRST HSHAGN ; no, try again
SKIPGE 5,HENTO
JRST HSHRV ; lookup - return value
JUMPE 5,HSHSTR ; no saved slot - store new value
HRLI 5,1 ; reclaim this slot first
HLLZM 5,0(4)
MOVEI 4,0(5) ; get saved address
CAIE 4,1 ; deleting?
JRST HSHSTR ; no, go store
HRLZI 5,-2 ; ADJUST COUNT
ADDM 5,0(1) ; decrement count by adding -2
HSHNIL: HRRZ 1,KNIL ; return NIL
SUB PP,BHC+2
RET
HSHSTO: HRLZI 5,2 ;ADJUST COUNT
ADDB 5,0(1)
JUMPGE 5,HSHOVR ;CHECK FOR OVERFLOW
HSHSTR: MOVSI 2,0(2)
HRR 2,0(PP)
MOVEM 2,0(4) ; store pair
HSHRV: HRRZ 1,0(4)
SUB PP,BHC+2
RET
; empty or deleted slot seen
HSHLKE: JUMPE 5,HSHLKU ; slot unused?
SKIPN HENTO ; storing?
HRRZM 4,HENTO ; save first reclaimed slot seen
HSHAGN: ADDI 4,0(3) ;reprobe address
CAILE 4,0(7) ;past end?
SUBI 4,-2(6) ; wrap around
CAIE 4,0(10) ; back to first probe?
JRST HSH1 ; no, continue
SKIPE HENTO ; back to start - insert?
JRST HSHLKU ; lookup, delete or saved, treat as unused
HSHOVR: SKIPL 0(1) ;DID IT OVERFLOW FOR COUNT?
HRROS 0(1) ;YES, PUT COUNT BACK. (SO IT STILL LOOKS LIKE HARRAY)
EXCH 1,-1(PP) ;save array, get original arg
PUSH PP,2 ; save key
HRRZ 5,@KSYSHS
CAIE 1,0(5) ; system table?
ERROR1 32,HSHBAD ; no, hash table overflow
MOVEI 1,-2(6) ; length
LSH 1,-1
ADDI 1,-2(6) ; 1.5 times length
CALL HARRY1 ; make new array
MOVEI 2,0(1)
MOVE 1,-2(PP) ;GET OLD ARRAY BACK
CALL UREHSH ; rehash from old to new
HRRM 1,@KSYSHS ; and save new
HSHBAD: POP PP,2 ; GET BACK PTR
POP PP,3 ; AND VALUE
SUB PP,BHC+1 ; throw away array
SETZM HENTO ;IN CASE ERROR CHANGED IT
JRST HSHLK3
; unused slot found
HSHLKU: SKIPN 5,HENTO ; empty, insert?
JRST HSHSTO ; yes, store
CAIG 5,2 ; delete or lookup?
JRST HSHNIL ; yes return NIL
MOVEI 4,0(5) ; use saved cell
JRST HSHSTO
; ADJUST A PROPOSED HASH ARRAY SIZE SO IT IS PRIME WRT THE TABLE
; OF INTERVALS
HSHADJ: IORI 1,1 ;MAKE ODD (NOT FACTOR OF 2)
PM1: MOVEI 6,↑D13 ;NUMBER OF TABLE ENTRIES TO BE CHECKED
PM3: CAMG 1,PRIMTB+2(6) ;SEE IF PRIME IS OUT OF RANGE
JRST PM2 ;IF SO, ASSUME IT IS RELATIVELY PRIME
MOVE 4,1
IDIV 4,PRIMTB+2(6) ;DIVIDE BY PRIME
JUMPN 5,PM2 ;FACTORS?
ADDI 1,2 ;YES
JRST PM1 ;START OVER
PM2: SOJGE 6,PM3 ;TRIED ALL PRIMES?
RET
PRIMTB: EXP 1,2,3,5,7,↑D11,↑D13,↑D17
EXP ↑D19,↑D23,↑D29,↑D31,↑D37,↑D41,↑D43,↑D47
;EVALA (FORM , ALIST)
EVALA: SETZ 1, ;PUT VALUES ON STACK
EVALA1: STE 2,LIST
JRST EVALA2
CARA 3,2
STE 3,LIST
JRST EVALAE
CDRA 4,3
PUSH PP,4
CDRA 2,2
AOJA 1,EVALA1
EVALA2: PUSH CP,[XWD 0,R]
MOVE 4,KPRGLM
JSP 5,CFRAM
HRRZ 3,CF ;GET ARGS BACK
GETAL 3,3
HRRZ 3,(3)
HRRZ 2,2(3)
MOVE 6,[Z 1(VP)]
EVALA3: STE 2,LIST ;PUT ON NAMES
JRST EVALA4
CARA 5,2
CARA 5,5
PUTNAM 5,@6
CDRA 2,2
AOJA 6,EVALA3
EVALA4: HRRZ 1,1(3) ;EVAL FORM
CALL EVAL
RET
EVALAE: MOVEI 1,0(3)
ERROR1 33,RESET
;MAKE A STRING OUT OF ANYTHING
MKSTR: CALL STRTY ;GET TYPE
CAIN 2,STPTT
RET ;ALREADY IS STRING
MKSTR3: SETZ 3, ;NO STRING PTR TO REUSE
MKSTRR: PUSH PP,3 ;HERE WITH STR PTR TO REUSE IN 3
CAIN 2,PNAMT
JRST MKSTRP
CALL MKSTRS ;SET UP TO STORE
CALL IPSTR ;INTERNAL PRINT STRING
MKSTR4: POP PP,3 ;TO REUSE?
JUMPE 3,MKSP ;NOPE - BOX
MOVEM 1,0(3) ;PUT IN THE GOODIES
MOVEI 1,0(3)
RET
MKSTRP: HLLZ 2,0(1) ;PNAME-MAKE STRING POINTER TO IT
TLZ 2,3777
LSH 2,-↑D8 ;GET LENGTH
IMULI 1,5 ;ADDR X 5
ADDI 1,1 ;+ 1 CHAR
IOR 1,2 ;LENGTH
JRST MKSTR4
;STORE 1 CHARACTER OF STRING
MKSTR1: SOSGE NFRECH
JRST MKSTR2 ;STRING STORAGE FULL
IDPB 1,FREEST
MOVSI 1,10
ADDM 1,UNP1 ;INCR LENGTH
RET
MKSTR2: HRLM 1,0(CP) ;SAVE CHAR
MOVE 1,UNP1
CALL STRGC ;GARBAGE COLLECT
MOVEM 1,UNP1 ;RETURNS UPDATED STRING POINTER
HLRZ 1,0(CP)
JRST MKSTR1
;SET UP TO STORE STRING
MKSTRS: LDB 4,[POINT 6,FREEST,5] ;CONVERT BYTE PONTER TO STRPTR
MOVEI 3,↑D29
SUB 3,4
IDIVI 3,7 ;CHAR NO. LAST CHAR. PREV. STRING
HRRZ 4,FREEST
IMULI 4,5
ADDI 4,1(3)
MOVEM 4,UNP1 ;STRING POINTER
RET
;STORE A STRING POINTER
MKSP: SKIPN 2,FREESP
JRST MKSP1
EXCH 1,0(2)
EXCH 1,FREESP ;UPDATE FREE
RET
MKSP1: CALL STPTGC
JRST MKSP
;MAKE ATOM OUT OF STRING OR PRINT REP. OF ANYTHING
MKATOM: CALL PACS
CALL MKSTR ;MAKE STRING
SBPC 3,1
JUMPLE 4,MKATM ;NULL STRING
ILDB 1,3
CALL PAC
SOJG 4,.-2
JRST MKATM
;SUBSTRING (X N M OLDSTPT)
;MAKE X A STRING IF IT ISNT ALREADY
;AND RETURN STRING OF CHARS N THRU M OF X
;IF M NIL ASSUME END OF X
;NIL IF X TOO SHORT
SUBSTR: HRRZ 3,4(VP) ;STRING PTR TO REUSE
STN 3,STPT ;IS IT STRING PTR??
JRST SUBST4 ;YEP
SETZ 1, ;NOPE - GET ONE TO USE
CALL MKSP
MOVEI 3,0(1) ;NEW PTR
HRRZ 1,1(VP) ;RESTORE 1
SUBST4: CALL STRTY ;GET TYPE
CAIE 2,STPTT ;STRING?
JRST SUBST1
MOVE 2,0(1) ;PUT OLD CONTENTS IN NEW BOX
MOVEM 2,0(3)
MOVEI 1,0(3) ;NEW BOX
JRST SUBST3
SUBST1: CALL MKSTRR ;OTHER TYPES, MAKE STRING
SUBST3: PUSH PP,1 ;SAVE STRING POINTER(NEW OR OLD)
HRRZ 1,2(VP) ;N
CALL IUNBOX
HRRZ 6,0(PP)
MOVE 6,0(6)
LSH 6,-↑D21 ;ORIG LEN
SKIPG 7,1 ;N NEGATIVE?
ADDI 7,1(6) ;YES - N←N+LEN+1
JUMPLE 7,FALSE
SUBI 7,1
PUSHN 6,2
PUSH CP,7 ;SECOND NUMBER
HRRZ 1,3(VP) ;M
CAMN 1,KNIL
SKIPA 1,6 ;M NIL , USE LENGTH
CALL IUNBOX
POP CP,7
POPN 6
JUMPG 1,.+2 ;M NEGATIVE?
ADDI 1,1(6) ;YES - M←M+LEN+1
CAILE 1,0(6)
JRST FALSE ;M GREATER LENGTH
SUB 1,7 ;M-N+1=NEW LENGTH
JUMPLE 1,FALSE ;TOO SHORT
DPB 1,SUBBP ;PUT IN LENGTH
SUBST2: POP PP,1
ADDM 7,0(1) ;ADD N-1 TO POS.
RET
SUBBP: POINT 14,@0(PP),14
;GET NEXT CHARACTER (X)
;MAKE X A STRING IF IT ISNT
;RETURNS NEXT CHARACTER OF STRING AND INCREMENTS STRING POINTER
;RETURNS NIL IF STRING IS EMPTY
GNC: CALL GNC1
CAMN 1,KNIL
RET
MK1ATM: CALL PACS ;RETURN ATOM
CALL PAC ;*****MAKE 1 CHAR ATOMS SOON
JRST MKATM
; GNCCODE
GNCC: CALL GNC1
CAME 1,KNIL
JRST MKN
RET
GNC1: CALL MKSTR
MOVE 4,0(1)
USBPC 2,4
ADD 4,[-7777777] ;LENGTH-1 AND CHAR. POS. + 1
JUMPL 4,FALSE ;RAN OFF END
MOVEM 4,0(1)
ILDB 1,2
RET
;GET LAST CHARACTER AND DECREMENT STRING POINTER
GLC: CALL GLC1
CAME 1,KNIL
JRST MK1ATM
RET
;GLCCODE
GLCC: CALL GLC1
CAME 1,KNIL
JRST MKN
RET
GLC1: CALL MKSTR
MOVE 4,0(1)
LSH 4,-↑D21 ;ORIG LENGTH
JUMPLE 4,FALSE ;STRING EMPTY
ADD 4,0(1) ;ADD LENGTH TO POINTER
SUBI 4,1
MOVE 3,[-10000000]
ADDM 3,0(1) ;SUBTR. 1 FROM ORIG. LENGTH
USBPC 2,4
ILDB 1,2
RET
;CONCAT(X Y... Z)
;CONCATENATE (COPIES OF) ANY NUMBER OF STRINGS
;ARGS TRANSFORMED TO STRINGS IF ARENT ALREADY
CONCAT: HRROI 7,0(VP)
TSC 7,1
CALL MKSTRS
MOVE 1,UNP1
CONCA2: AOBJP 7,MKSP
HRRZ 1,0(7)
PUSH CP,7
CALL CONC1 ;STORE AT END OF STRING STORAGE
POP CP,7
JRST CONCA2
CONC1: CALL STRTY ;GET TYPE
CAIN 2,STPTT
JRST COPST1 ;STRING - COPY IT
CAIN 2,PNAMT
JRST COPPN1 ;PNAME - COPY
IPSTR: MOVEI 2,MKSTR1 ;OTHER TYPES USE INTERNAL PRINT
CALL IPRE
CONC2: MOVE 1,UNP1 ;GET POINTER
RET
COPSTR: CALL MKSTRS ;SETUP
COPST1: SBPC 2,1 ;CONVERT TO BYTE PTR
COPST3: JUMPLE 3,COPST4 ;LENGTH 0 OR NEG. ?
PUSH CP,2 ;BYTE PTR TO STACK SO GC WILL UPDATE IT
COPST2: ILDB 1,0(CP) ;COPY STRING
CALL MKSTR1
SOJG 3,COPST2
POP CP,2
COPST4: MOVE 1,UNP1 ;RETURN UNBOXED STRING POINTER
RET
COPPNM: CALL MKSTRS ;PNAME - SETUP
COPPN1: HRLI 1,440700 ;MAKE BYTE POINTER
ILDB 3,1 ;GET LENGTH
MOVE 2,1
JRST COPST3 ;AND COPY
STRTY: LDT 2,1 ;GET TYPE
CAIE 2,ATOMT ;ATOM?
RET ;NO - OK
HLRZ 1,2(1) ;ATOM - GET TYPE OF PNAME
JRST STRTY
;RPLSTR(STR1 N STR2)
;REPLACE STRING 1 BEGINNING AT CHARACTER N BY STRING 2
;CONVERTS ARGS TO STRINGS
;RETURNS STRING 1, WILL BE DIFFERENT IF WASNT STRING
;ERROR IF STRING 2 TOO LONG.... STRING1 MAY BE SMASHED
RPLSTR: CALL STRTY ;GET TYPE
CAIN 2,STPTT
JRST RPLSTS
CALL MKSTRS ;NOT STRING - SET UP TO MAKE ONE
CAIN 2,PNAMT
JRST RPLSTP
CALL IPSTR ;INTERNAL PRINT
RPLST3: CALL MKSP ;BOX STRING POINTER
RPLST2: PUSH PP,1 ;SAVE STRING PTR(NEW OR OLD)
HRRZ 1,2(VP) ;N
CAMN 1,KNIL
SKIPA 1,[1] ;NIL MEANS 1
CALL IUNBOX
JUMPG 1,RPLST5
HRRZ 2,0(PP) ;N NEGATIVE
MOVE 2,0(2) ;... GET LENGTH
LSH 2,-↑D21 ;... OF STRING1
ADDI 1,1(2) ;...AND ADD TO N+1
JUMPLE 1,RPLERR
RPLST5: SUBI 1,1
IMUL 1,[-7777777]
MOVE 2,0(PP)
ADD 1,0(2) ;PTR TO SUBSTR(STRING1 N)
JUMPL 1,RPLERR ;STRING1 LESS N LONG
USBPC 4,1
HRRZ 1,3(VP)
CALL STRTY
CAIN 2,STPTT
JRST RPLS1
CAIN 2,PNAMT
JRST RPLP1
MOVEM 4,UNP1 ;BYTE POINTER
MOVEM 5,UNP2 ;LENGTH REMAINING
MOVEI 2,RPLST1
CALL IPRE
RPLST4: POP PP,1
RET
RPLST1: SOSGE UNP2 ;SUBR CALLED FROM IPRE
JRST RPLERR
IDPB 1,UNP1
RET
RPLSTS: MOVE 2,0(1) ;FIRST ARG IS STRING
TLZ 2,777770
IDIVI 2,5 ;CHECK LOC OF CHARACTERS
LDT 2,2
CAIE 2,PNAMT
JRST RPLST2
CALL COPSTR ;IN PNAME SPACE - COPY
HRRZ 2,1(VP)
MOVEM 1,0(2) ;SMASH NEW POINTER INTO OLD SLOT
MOVEI 1,0(2)
JRST RPLST2
RPLSTP: CALL COPPN1 ;PNAME - COPY
JRST RPLST3
RPLS1: SBPC 2,1
RPLS3: CAMLE 3,5
JRST RPLERR
JUMPE 3,RPLST4
RPLS2: ILDB 1,2
IDPB 1,4
SOJG 3,RPLS2
JRST RPLST4
RPLP1: HRLI 1,440700 ;SECONG ARG PNAME
ILDB 3,1 ;GET LENGTH
MOVE 2,1
JRST RPLS3
RPLERR: HRRZ 1,3(VP)
ERROR1 33,RESET
; COPYSTRING(X) = CONCAT(X)
UCPCST: CALL MKSTRS
CALL CONC1
JRST MKSP
; copy string from compiled code
; called by
; JSP 6,CPCSTR
; asciz/string/
CPCSTR: HRLI 6,440700 ; make LH of byte pointer
PUSH CP,6 ; save on stack in case of GC
CALL MKSTRS ; initialize string maker
JRST .+2
CALL MKSTR1
ILDB 1,0(CP) ; get char
JUMPN 1,.-2 ; unless 0
MOVE 1,UNP1
CALL MKSP
POP CP,6
JRST 1(6)
; PRINTSTRING(X FILE) = PRIN1(X FILE) WITH MARGIN CHECKING OFF
UPRCST: TRZ F,PMCFLG
CALL OFSET
CALL PRIN1A
HRRZ 1,FILEA(FX)
RET
; print string from compiled code
; called by
; HRRZ 1,file
; JSP 6,PRCSTR
; ASCIZ/string/
PRCSTR: HRLI 6,440700
PUSH CP,6
MOVE 2,1
CALL OFSET
JRST .+2
CALL FOUT
ILDB 1,(CP)
JUMPN 1,.-2
POP CP,6
HRRZ 1,FILEA(FX)
JRST 1(6)
;I-O RELATED FUNCTIONS
RADIKS: CAMN 1,KNIL
JRST RDKS1
CALL IUNBOX
EXCH 1,URADIX
TLZN F,PNEGF ;TEST CURRENT FLAG
MOVN 1,1 ;0 - RET NEG VAL
MOVE 2,URADIX
CAIL 2,0
TLO F,PNEGF ;NEW VAL POS, SET FLAG 1
MOVMM 2,URADIX
MOVEM F,TFLGS
JRST MKN
RDKS1: MOVE 1,URADIX
TLNN F,PNEGF
MOVN 1,1
JRST MKN
OPENP: CAMN 1,KNIL
JRST OPNLST
CALL OPENP1 ;SEARCH FOR INPUT OR OUTPUT FILE
JRST FALSE ;FAILS
RET
OPENP1: CAMN 2,KNIL
JRST FSCH ;ANY OPEN FILE
CAMN 2,KOUTPUT
JRST OPENP2
CAMN 2,KINPUT
CALL IFSCH
JRST IOFSCH ;OPEN FOR INPUT AND OUTPUT
JRST RSKP
OPENP2: MOVEI 2,0(1)
CALL OFSCH ;LOOK FOR OUTPUT FILE
JRST OPNP3 ;NOT FOUND
MOVEI 1,0(2)
JRST RSKP
OPNP3: MOVEI 1,0(2) ;TRY I/O
JRST IOFSCH
;HACK JSYS FN (JSYS # AC1 AC2 AC3 RESULTAC)
UJSYS: CALL IUNBOX
PUSHN 1 ;JSYS NUMBER
HRRZ 1,5(VP)
CAMN 1,KNIL
SKIPA 1,[1] ;DEFAULT RESULT IS AC1
CALL IUNBOX
PUSHN 1
HRRZ 1,4(VP)
CAMN 1,KNIL
SKIPA 1,[0]
CALL IUNBOX
PUSHN 1
HRRZ 1,3(VP)
CAMN 1,KNIL
SKIPA 1,[0]
CALL IUNBOX
PUSHN 1
HRRZ 1,2(VP)
CAMN 1,KNIL
SKIPA 1,[0]
CALL IUNBOX
POPN 2
POPN 3
POPN TP
POPN 5
JSYS 0(5)
JFCL
JFCL
MOVE 1,0(TP)
JRST MKN
NCHARS: CAME 2,KNIL
JRST NCHR4
LDT 2,1 ;GET ARG TYPE
CAIE 2,ATOMT ;ATOM?
JRST NCHR1 ;NOT ATOM
HLRZ 1,2(1)
NCHR3: CALL UPATM ;CONSTRUCT COUNT, POINTER
MOVEI 1,0(4) ;RETURN COUNT
JRST MKN
NCHR1: CAIN 2,STPTT ;STRING?
JRST NCHR3 ;YES -EASY
MOVEI 4,IPRE
NCHR5: SETZM UNP1
MOVEI 2,NCHR2 ;SET UP INTERNAL PRINT
CALL (4)
MOVE 1,UNP1
JRST MKN
NCHR4: MOVEI 4,IPRE2
JRST NCHR5
NCHR2: AOS UNP1
RET
POSITN: MOVE 3,FP
CAMN 1,KNIL ;NIL ARG?
JRST POSN1 ;YES, USE STND OUTPUT FILE
CALL FSCH
JRST ILLIF ;NO SUCH FILE
TRNN 3,-1 ;TTY IN?
MOVEI 3,1 ;YES, USE TTY OUT
POSN1: HRRZ 1,2(VP) ;SECOND ARG GIVEN?
CAMN 1,KNIL
JRST POSN2 ;NO
PUSHN 3
CALL IUNBOX
POPN 3
MOVEI 2,0(1)
HRRZ 1,CHPOS(3)
HRRM 2,CHPOS(3) ;YES - SET POSITION
SKIPA
POSN2: HRRZ 1,CHPOS(3) ;POSITION ON LINE
JRST MKN
TERPRI: MOVEI 2,0(1)
CALL OFSET
MOVEI 1,EOL ;PRINT EOL
CALL PREC
JRST FALSE
;PACK AND UNPACK
PACK: CALL PACS ;INITIALIZE ATOM PACKER
CAMN 1,KNIL ;NIL GIVEN
JRST MKATM ;RETURN EMPTY ATOM
STE 1,LIST ;ARG LIST?
ERROR1 33,PACK ;NOPE - ERROR
PACK1: STE 1,LIST ;END OF LIST?
JRST MKATM ;YES CONSTRUCT ATOM AND RETURN
PUSH PP,1 ;NO, SAVE LIST
CARA 1,1 ;GET NEXT ELEMENT
MOVEI 2,PAC
CALL IPRE ;INTERNAL PRINT
POP PP,1
CDRA 1,1
JRST PACK1
PACKN: CALL PACS ;PACK INDEF ARGS
CALL MPARG
CALL PACKN1
JRST MKATM
PACKN1: MOVEI 2,PAC
CALL IPRE
RET
PACKC: CALL PACS
PACKC1: CAMN 1,KNIL
JRST MKATM
PUSH PP,1
CARA 1,1
CALL IUNBOX
CALL PAC
POP PP,1
CDRA 1,1
JRST PACKC1
UNPACK: SETZM UNP1 ;INITIALIZE LIST
MOVEI 4,IPRE
CAME 2,KNIL ;SECOND ARG NIL?
MOVEI 4,IPRE2 ;NO - USE INTERNAL PRIN2
MOVEI 2,UNP ;INTERNAL SUBR FOR CHARS
CALL (4) ;INTERNAL PRINT
UNP6: SKIPG UNP1
JRST FALSE ;NO CHARACTERS
MOVE 1,UNP2
RET
UNP: CALL SAV27 ;SAVE AC'S 2-7
CALL PACS ;INITIALIZE ATOM PACKER
CALL PAC ;PACK CHARACTER
PUSH PP,UNP2
CALL MKATM
POP PP,UNP2
UNP5: PUSH PP,UNP1 ;GET LAST ON STACK IN CASE GC
MOVE 2,UNP2
CALL CONS
HLRZ 2,0(1)
MOVEM 2,UNP2 ;SAVE LIST SO FAR
MOVE 2,KNIL
HRLM 2,0(1) ;RPLACD (NEW) LAST WITH NIL
POP PP,2 ;GET BACK OLD LAST
JUMPE 2,UNP3 ;NO LIST SO FAR
HRLM 1,0(2) ;RPLACD LAST WITH NEW ELEMENT
UNP4: MOVEM 1,UNP1 ;BECOMES NEW LAST
CALL RES27 ;RESTORE AC'S 2-7
RET
UNP3: MOVEM 1,UNP2 ;IS FIRST (WHOLE) OF LIST
JRST UNP4
U UNP1
U UNP2
CHCON: SETZM UNP1 ;INITIALIZE LIST
MOVEI 4,IPRE
CAME 2,KNIL ;SECOND ARG NIL?
MOVEI 4,IPRE2 ;NO- USE INTERNAL PRIN2
MOVEI 2,CHCN
CALL (4)
JRST UNP6
CHCN: CALL SAV27 ;INTERNAL SUBR FOR CHARS- CHCON
ADDI 1,ASZ ;BOX
JRST UNP5
CHCON1: MOVEI 2,CHCN1
CALL IPRE
JRST FALSE
CHCN1: ADDI 1,ASZ
INTOFF
HRRZ CP,CF
ADDI CP,FLGWD ;FLUSH TEMS OF THIS FRAME
HRLI CP,@ICPC
INTON
RET
; NTHCHARCODE
NTHCHC: CALL NTHCH
CAME 1,KNIL
JRST MKN
RET
; NTHCHAR
NTHCHR: CALL NTHCH
CAMN 1,KNIL
RET
JRST MK1ATM
NTHCH: CAME 3,KNIL
JRST NTHCH2
LDT 3,1
CAIN 3,STPTT
JRST NTHC3
CAIE 3,ATOMT
JRST NTHCHN
HLRZ 1,2(1)
HRRM 1,1(VP)
NTHC3: MOVEI 1,0(2)
CALL IUNBOX
MOVE 7,1
HRRZ 1,1(VP)
CALL UPATM
SKIPGE 7
ADDI 7,1(4)
JUMPLE 7,FALSE
CAILE 7,0(4)
JRST FALSE
SUBI 7,1
IDIVI 7,5
ADDI 3,0(7)
IBP 3
SOJGE 10,.-1
NTHC1: LDB 1,3
NTHC2: RET
NTHCH2: MOVEI 3,IPRE2
SKIPA
NTHCHN: MOVEI 3,IPRE
MOVEM 3,NTHCP
MOVEI 1,0(2)
CALL IUNBOX
JUMPG 1,NTHC4
PUSHN 1
HRRZ 1,1(VP)
SETZM UNP1 ;NTHCHAR WITH NON-STRING OR ATOM
MOVEI 2,NCHR2 ;...AND NEG. COUNT
HRRZ 3,4(VP) ;...AND READTABLE
CALL @NTHCP ;...IS SLOW, BUT SERVES ONE RIGHT
POPN 1
ADD 1,UNP1
ADDI 1,1
JUMPLE 1,FALSE
NTHC4: MOVEM 1,UNP1
MOVEM CP,UNP2
HRRZ 1,1(VP) ;GET ARG BACK
MOVEI 2,NTHCC ;ROUTINE FOR INTERNAL PRINT
HRRZ 3,4(VP) ;READTABLE
CALL @NTHCP ;INTERNAL PRINT
JRST FALSE ;TOO FEW CHARACTERS
NTHCC: SOSLE UNP1
RET
MOVE CP,UNP2 ;RESTORE CP
JRST NTHC2 ;AND MAKE ATOM
CHRCT: CALL IUNBOX ;CHARACTER, UNBOX NUMBER
JRST MK1ATM ;AND MAKE ATOM
U NTHCP
;DATE AND TIME FNS
; SETFILEPTR(file position)
STFPTR: CALL FPTRX ; get FX
HRRZ 1,2(VP)
CALL IUNBOX ; IUNBOX doesn't change FX????
HLLZS CHPOS(FX) ; set position to 0
HLLOS FCHAR(FX) ; clear 1 char buffer
MOVE 2,1
HRRZ 1,FILEN(FX)
SFPTR
JRST SFPT3
HRRZ 1,2(VP)
RET
; GETFILEPTR(file)
GFPTR: CALL FGFPTR
JRST MKN
FGFPTR: CALL FPTRX
HRRZ 1,FILEN(FX)
RFPTR ;GET PRESENT FILE PTR
JRST SFPT3
GFPT1: HRRE 3,FCHAR(FX)
JUMPL 3,GFPT2
SUBI 2,1 ; there's a character in the buffer
CAIN 3,EOL
SUBI 2,1 ;EOL IN LISP IS CR/LF IN SYSTEM
GFPT2: MOVE 1,2
RET
; GETEOFPTR(file)
GEPTR: CALL FPTRX
HRRZ 1,FILEN(FX)
RFPTR ; PRESENT POINTER
JRST SFPT3
MOVE 3,2 ; SAVE IT
HRROI 2,-1
SFPTR ; SET TO END
JRST SFPT3
RFPTR ; GET THE EOF POINTER
JRST SFPT3
CAMN 2,3 ; IF WERE AT EOF, CHECK FCHAR
JRST EFPT2
EXCH 2,3
SFPTR ; RESTORE OLD POSITION
JRST SFPT3
MOVE 1,3
JRST MKN
EFPT2: CALL GFPT1
JRST MKN
; get file index to FX from file in 1.
FPTRX: PUSH PP,1
CAMN 1,KNIL
JRST FPTR1
CALL FSCH
ERROR1 15,RESET ; FILE NOT OPEN
SKIPA FX,3
FPTR1: MOVE FX,FR ; USE STANDARD INPUT FILE
POP PP,4
RET
REPEAT 0,<
; OLD SET FILE POINTER
SPTR: CAMN 1,KNIL
JRST SFPT5
CALL FSCH
ERROR1 15,RESET ;FILE NOT OPEN
MOVEI FX,0(3)
SKIPA
SFPT5: MOVE FX,FR ;USE STANDARD INPUT FILE
MOVEM FX,FRX
HRRZ 1,FILEN(FX)
RFPTR ;GET PRESENT FILE PTR
JRST SFPT3
HRRE 3,FCHAR(FX)
JUMPL 3,SFPT1
SUBI 2,1
CAIN 3,EOL
SUBI 2,1 ;EOL IN LISP IS CR/LF IN SYSTEM
SFPT1: PUSHN 2
HRRZ 1,2(VP)
CAMN 1,KNIL
JRST SFPT2 ;JUST RETURN PRESENT PTR
CALL IUNBOX
MOVE FX,FRX
HLLZS CHPOS(FX)
HLLOS FCHAR(FX)
MOVE 2,1
HRRZ 1,FILEN(FX)
SFPTR
JRST SFPT4
SFPT2: POPN 1
JRST MKN
>
ILARG1: HRRZ 1,1(VP)
ERROR1 33,RESET
ILARG2:
HRRZ 1,2(VP)
ERROR1 33,RESET
SFPT3: MOVE 1,4
ERROR1 33,RESET
DATE: CAMN 1,KNIL
SKIPA 1,[0]
CALL IUNBOX
MOVE 3,1 ;FLGS FOR WHICH DATE
SETO 2, ;STANDARD FORMAT
MOVE 1,IOFNMP
ODTIM ;DATE AND TIME TO STRING
PUSHN 1
CALL MKSTRS
MOVE 10,IOFNMP
JRST DATE2
DATE1: ILDB 1,10
CALL MKSTR1
DATE2: CAME 10,0(CP)
JRST DATE1
POPN 2
MOVE 1,UNP1
JRST MKSP
CLOCK: CAMN 1,KNIL
JRST CLK0
CALL IUNBOX
CAIG 1,3
CAIGE 1,0
JRST FALSE
JRST .+1(1)
JRST CLK0
JRST CLK1
JRST CLK2
JRST CLK3
CLK0: TIME ;TIME IN MS
JRST MKN
CLK1: MOVE 1,LOGTOD ;TIME OF STARTUP OF LISP
JRST MKN
CLK2: GETJRT ;RUNTIME THIS JOB
SUB 1,LOGRT ;LESS GC AND STARTUP
SUB 1,GCRT
JRST MKN
CLK3: MOVE 1,GCRT ;GC TIME
JRST MKN
;PUT STRINGS INTO VARIOUS TTY BUFFERS
BKSYSB: CALL BKSET
BKSYS2: JUMPLE 4,FALSE
MOVEI FX,0
HRRZ 1,FILEN(FX)
BKSYS1: ILDB 2,3
CAIN 2,37
SKIPN KL20F
CAIA
MOVEI 2,15 ;ON KL20 REPLACE 37'S BY CR
STI
SOJG 4,BKSYS1
HRRZ 1,1(VP) ;OK - RET STRING
RET
BKLNBF: CALL BKSET
JUMPLE 4,FALSE
SKIPLE LNBFC
JRST FALSE ;CANT DO IF BUFFER NOT EMPTY
MOVEM 3,BKLNP
MOVEM 4,BKLNC
CALL GCHIB
HRRZ 1,1(VP)
RET
BKCHAR: SOSGE BKLNC ;GET CHAR FROM BACKED STRING FOR LNBF
JRST .+3
ILDB 1,BKLNP
JRST RSKP
TLZ F,BKFLG ;FINISH WITH CHARS FROM TTY
RET ;RETURN NO SKIP
BKSET: CALL STRTY
CAIN 2,STPTT
JRST BKSET1
CAIE 2,PNAMT
JRST BKSET2
MOVEI 3,0(1)
HRLI 3,440700
ILDB 4,3
RET
BKSET1: SBPC 3,1
RET
BKSET2: MOVNI 4,1
RET
U BKLNP
U BKLNC
ESCP: SETO 2, ;ARG T TURNS ON ESCAPE CHAR FOR READ
CAMN 1,KNIL
SETZ 2, ;ARG NIL TURN OFF
EXCH 2,ESCONF
JUMPE 2,FALSE ;WAS OFF - RET NIL
JRST TRUE
RDMACS: MOVEI 2,0
CAME 1,KNIL
SETO 2,
EXCH 2,RMONF
JUMPE 2,FALSE
JRST TRUE
LINLTH: CAMN 1,KNIL
SKIPA 1,LINSIZ
CALL IUNBOX
EXCH 1,LINSIZ
JRST MKN
SETPLV: CAME 1,KNIL
JRST SETPL1
CAME 2,KNIL
JRST SETPL2
GETPLV: MOVE 1,PPDLVL
CALL MKN
PUSH PP,1
MOVE 1,PPLVL
TLNE F,NEGPLF
MOVN 1,1
CALL MKN
POP PP,2
JRST CONS
SETPL1: CAME 2,KNIL ;1=NON-NIL
JRST SETPL3
STE 1,LIST
JRST SETPL4
CDRA 2,1 ;1=LISTP, 2=NIL
CARA 1,1
JRST SETPLV
SETPL2: PUSH PP,2 ;1=NIL, 2=NON-NIL
CALL GETPLV
EXCH 1,0(PP)
CALL IUNBOX
MOVEM 1,PPDLVL
SETPL5: POP PP,1
RET
SETPL3: PUSH PP,1 ;1,2=NON-NIL
CALL SETPL2
SETPL6: EXCH 1,0(PP)
CALL IUNBOX
TLZ F,NEGPLF
JUMPGE 1,.+3
TLO F,NEGPLF
MOVN 1,1
MOVEM 1,PPLVL
MOVEM F,TFLGS
JRST SETPL5
SETPL4: PUSH PP,1 ;1=NON-NIL,NON-LIST, 2=NIL
CALL GETPLV
JRST SETPL6
READP: CALL IFSET
JUMPN FX,READP1 ;TTY?
SKIPLE LNBFC
JRST TRUE
READP1: HRRE 1,FCHAR(FX)
HRRZ 3,TTYTBL ;GET THE TERMINAL TABLE
CAMN 2,KNIL ;NO EOL CHECK IF FLG=T
CAME 1,CTLEOL(3) ;IGNORE EOL IN CHAR BUFFER
JUMPGE 1,TRUE
CAIN FX,NFILES ;STRING?
JRST READP2 ;YES
HRRZ 1,FILEN(FX) ;NO - IT'S A REAL FILE
SIBE
SKIPA
JRST FALSE
JRST TRUE
READP2: HRRZ 1,FILEA(FX) ;GET THE STRING
MOVE 1,(1) ;GET THE STRING POINTER
TLNE 1,777770 ;TEST THE COUNT - ZERO?
JRST TRUE ;NO
JRST FALSE ;YES
;SET INTERRUPT CHARACTERS
IFE TEN50,<
;INIT INTERRUPT CHARS TO CURRENT SYSTEM
IINTCR: CALL OFFINT ;HERE TO RESET
IINTC: MOVSI 2,CTCT10 ;HERE TO SET FIRST TIME
SKIPE KL20F
IINTC2: MOVSI 2,CTCT20 ;HERE FOR TOPS20
IINTC3: HRRI 2,CTCT
BLT 2,CTCT+NCTCT-1
MOVE 2,[XWD UCTVAR,UCTVAR+1]
BLT 2,UCTVAR+NUCTCT-1
HRRZ 1,KCTRLU
MOVEM 1,UCTVAR ;SET UP CTRLUFLG
CALL SETINT
RET
;GET/SET BRK/SEPR/PRT
SETBRK: MOVEI 6,SBBITS
JRST SETBSS
SETSEP: MOVEI 6,SSBITS
JRST SETBSS
SETBR1: MOVE 4,[Z ORGRDT+2+RDNUBW(1)]
CAME 5,SYSRT2 ;ARE WE RESETTING SYSTEM TABLE?
MOVE 4,SYSRT2 ;NO, RESET FROM SYSTEM RATHER THAN ORIG.
MOVEI 1,177
SETBR2: MOVE 2,@4
MOVE 3,@5
TDNN 2,1(6) ;IS BIT SET IN ORIGINAL?
JRST .+4 ;NO
TDNN 3,1(6) ;YES - IS BIT ALREADY SET?
HLL 3,0(6) ;NO - MAKE IT A BREAKCHAR OR A SEPRCHAR
JRST .+3 ;YES - DO NOTHING
TDNE 3,1(6) ;IS BIT ALREADY SET (IT'S NOT IN ORIG)
HRLI 3,0 ;YES, MAKE IT A REGULAR LETTER
MOVEM 3,@5
SOJGE 1,SETBR2
JRST FALSE
SETBSS: MOVEI 5,(1)
MOVEI 1,(3)
CALL GETRDT
EXCH 1,5
ADD 5,[Z RDNUBW+2(1)]
CAMN 1,KT
JRST SETBR1
CAMN 1,KNIL
JRST STBS1A
LDT 7,1
CAIE 7,LISTT
ERROR1 33,R
STBS1A: MOVEI 7,0(2)
CAMN 7,KNIL
JRST SETBS7
SETBS3: CAMN 1,KNIL ;MORE CHARS?
JRST STBS10
PUSH PP,1
CARA 1,1 ;NEXT CHAR
LDT 2,1
CAIN 2,SMALLT ;NUMBER?
JRST SETBS1 ;YES, IS CHARACTER CODE
CAIN 2,STPTT
JRST SETBS6
CAIE 2,ATOMT
JRST ARGNA
HLRZ 1,2(1)
SETBS6: CALL UPATM
ILDB 1,3
SETBS2: MOVE 2,@5
CAMN 7,KNIL ;SET?
JRST SETBS9 ;YES
CAIE 7,ASZ ;NO - CLEAR IT?
JRST SETBS8 ;NO - ADD
SETZM @5 ;YES - MAKE IT A REGULAR LETTER
JRST SETBS5
SETBS8: TDNE 2,1(6) ;ADD - IS BIT ALREADY SET?
JRST SETBS5 ;YES - DO NOTHING
MOVE 2,0(6) ;NO - SET TO BREAKCHAR OR SEPRHAR
HLLM 2,@5
SETBS5: POP PP,1
CDRA 1,1 ;REST OF LIST
JRST SETBS3
SETBS1: MOVEI 1,-ASZ(1)
JRST SETBS2
SETBS7: SETZM TMPBLK
SETZM TMPBLK+1
SETZM TMPBLK+2
SETZM TMPBLK+3
JRST SETBS3
SETBS9: IDIVI 1,40
MOVNI 2,(2)
MOVSI 4,400000
ROT 4,(2)
IORM 4,TMPBLK(1)
JRST SETBS5
STBS10: CAME 7,KNIL ;SET?
JRST FALSE ;NO
MOVEI 1,177 ;YES
STBS11: MOVEI 3,(1)
IDIVI 3,40
MOVNI 4,(4)
MOVSI 2,400000
ROT 2,(4)
MOVE 3,TMPBLK(3)
TDNE 3,2
JRST STBS12
MOVE 2,@5
TDNN 2,1(6)
JRST STBS13
SETZ 2,
JRST STBS14
STBS12: MOVE 2,@5
TDNN 2,1(6)
SKIPA 2,0(6)
STBS14: CAME 2,@5 ;SO A PAGE WON'T GET UNSHARED
HLLM 2,@5
STBS13: SOJGE 1,STBS11
JRST FALSE
SBBITS: XWD BRKBIT+PRTBIT,0
XWD BRKBIT,0
SSBITS: XWD SEPBIT+PRTBIT,0
XWD SEPBIT,0
SPBITS: XWD PRTBIT,0
XWD PRTBIT,0
U TMPBLK,4
GETBRK: MOVSI 6,BRKBIT
JRST GETBSS
GETSEP: MOVSI 6,SEPBIT
GETBSS: MOVEI 2,(1) ;SELECT WHICH READTABLE
CALL IRTSET
MOVEI 1,177 ;CONSTRUCT LIST OF CHARACTER CODES
PUSH PP,KNIL ;INIT LIST
GETBS2: MOVE 3,@BSTAB ;GET A CHARACTER ENTRY
TDNN 3,6 ;IS THE BIT SET?
JRST GETBS1 ;NO
MOVEI 2,0(1) ;YES, CONS ITS CODE ONTO LIST
CALL SAV27
MOVEI 1,ASZ(2) ;MAKE CHAR INTO (SMALL) NUMBER
MOVE 2,0(PP) ;LIST
CALL CONS
MOVEM 1,0(PP)
CALL RES27 ;RESTORE AC'S 2-7
MOVEI 1,0(2)
GETBS1: SOJGE 1,GETBS2
POP PP,1
RET
; READTABLE CONSTANTS AND FLAGS
EOLBIT==4000
IMEDBT==2000
ALONBT==1000
FRSTBT==400
BRKBIT==200
SEPBIT==100
PRTBIT==40
STRBIT==20
ESCBIT==10
RDTMSK==350
JPBITS==7
RDCKWD==1 ;READ TABLE CHECK WORD
RDNUBW==0 ;NUMBER OF UNBOXED WORDS IN A READTABLE
RTSIZE==200+RDNUBW+RDCKWD ;SIZE OF A READTABLE ARRAY
JMPFLD: POINT 3,@BSTAB,17
; THE ORIGINAL SYSTEM READTABLE
ORGRDT:
BLOCK 2 ;DUMMY HEADER
SEPBIT+PRTBIT,,0 ;NULL
REPEAT 8,<0> ;↑A-↑H
SEPBIT+PRTBIT,,0 ;TAB
SEPBIT+PRTBIT,,0 ;LF
0 ;↑K
SEPBIT+PRTBIT,,0 ;↑L
SEPBIT+PRTBIT,,0 ;CR
REPEAT 21,<0> ;↑N-RS
SEPBIT+PRTBIT,,0; EOL
SEPBIT+PRTBIT,,0 ;SPACE
0 ;!
BRKBIT+STRBIT+PRTBIT,,0;"
0 ;#
0 ;$
ESCBIT+PRTBIT,,0 ;%
0 ;&
0 ;'
BRKBIT+PRTBIT+3,,0 ;(
BRKBIT+PRTBIT+4,,0 ;)
REPEAT <"Z"-"*"+1>,<0>;* - Z
BRKBIT+PRTBIT+2,,0 ;[
0 ;\
BRKBIT+PRTBIT+1,,0 ;]
REPEAT <200-"↑">,<0> ;↑ - RUBOUT
0 ;DUMMY BOXED CHECK WORD
;TERMINALTABLE CONSTANTS
TTYSIZ==↑D16 ;SIZE OF TERMINAL TABLE
CTLA==2
CTLQ==3
CTLR==4
CTLV==5
CTLEOL==6
CCOCW1==7
CCOCW2==10
CTQMSG==11
CAMSG1==12 ;FIRST ↑A MESSAGE
CAMSG2==13 ;NTH ↑A MESSAGE
CAMSGP==14 ;POST ↑A MESSAGE
CAMSGE==15 ;EMPTY BUFFER ↑A MESSAGE
ECHFLG==16 ;NO ECHO DELETED ↑A FLAG
LBFLGW==17 ;NO LINE BUFFERING FLAG WORD
ECHMDW==20 ;ECHO MODE WORD
RASMOD==21 ;RAISE MODE WORD
;ORIGINAL SYSTEM TERMINAL TABLE - TENEX
;
ORGTTX:
BLOCK 2
"A"-100 ;CHAR DELETE
"Q"-100 ;LINE DELETE
"R"-100 ;RETYPE
"V"-100 ;CONTROL V
37 ;EOL
BYTE (2) 0,0,1,1,1,1,1,2,1,3,2,1,1,2,1,1,1,0
BYTE (2) 0,1,1,1,1,2,1,1,1,3,1,1,1,2
ASCIZ/##
/ ;↑Q MESSAGE
ASCIZ/\/ ;↑A MESSAGES
0
ASCIZ/\/
ASCIZ/##
/
0 ;NO ECHO DELETE ↑A FLAG
0 ;NO LINE BUFFERING FLAG
1 ;ECHO MODE
-1 ;RAISE MODE,p= IS 0, < IS NIL, > IS T
ORGTT2: BLOCK 2
177 ;RUBOUT - DELETE CHAR
"U"-100
"R"-100 ;RETYPE
"V"-100 ;CONTROL V
37 ;EOL
; ,A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q
BYTE (2) 0,1,1,1,1,1,1,2,1,3,2,1,1,2,1,1,1,1
; R,S,T,U,V,W,X,Y,Z,$,.,.,.,37
BYTE (2) 0,1,1,2,1,2,1,1,1,2,1,1,1,2
ASCIZ/##
/ ;↑Q MESSAGE
ASCIZ/\/
0
ASCIZ/\/
ASCIZ/##
/
0
0
1 ;ECHO MODE
-1 ;RASE MODE
; SETREADTABLE(RDTBL,TBLFLG)
SETRDT: CALL GETRDT
CAMN 2,KNIL ;SETTING CURRENT TABLE?
JRST .+3 ;YES
MOVEI 3,SYSRDT ;NO
CAIA
MOVEI 3,CURRDT
EXCH 1,(3) ;SET READTABLE
MOVEI 2,CURRT2 ;SET PRT TO CHAR. DATA
CAIE 3,CURRDT
MOVEI 2,SYSRT2
MOVE 3,(3)
ADD 3,[Z 2+RDNUBW(1)]
MOVEM 3,(2)
RET
; GETREADTABLE(RDTBL)
GETRDT: CAME 1,KNIL ;IS SOURCE THECURRENT TABLE
JRST .+3 ;NO
MOVE 1,CURRDT ;YES
RET
CAME 1,KT ;IS SOURCE THE SYSTEM TABLE?
JRST .+3 ;NO
MOVE 1,SYSRDT ;YES
RET
CALL CKRDTS ;IS IT A READTABLE?
ERROR1 46,R ;NO
RET
; COPYREADTABLE(RDTBL)
CPYRDT: CAMN 1,KORIG
JRST .+3
CALL GETRDT
CAIA
MOVEI 1,ORGRDT
PUSH PP,1
CALL RTALOC
POP PP,2
JRST RTCPY
RTALOC: MOVEI 1,RTSIZE+2 ;ALLOCATE A READTABLE
CALL ALLOC1 ;THIS IS A QUICK AND DIRRTY (ARRAY ...)
MOVEI 2,RDNUBW+2 ;...MUST BE DONE THIS WAY CAUSE IT
HRRM 2,1(1) ;CALLED DURING INITIALIZATION
RET
RTCPY: PUSH PP,1 ;COPY A READTABLE
HRL 1,2 ;BUILD BLT DATA
ADD 1,BHC+2
MOVEI 4,RTSIZE-1(1)
BLT 1,(4) ;COPY
POP PP,1
CAIE 2,ORGRDT
RET
MOVE 3,KNIL ;FILL OUT FNS WITH NIL
MOVEI 2,(1)
ADD 2,[-200,,RDNUBW+2]
HRRM 3,(2)
AOBJN 2,.-1
RET
; RESETREADTABLE(RDTBL,reset/RDTBL)
RSTRDT: CALL GETRDT
EXCH 1,2
CAMN 1,KORIG
JRST .+3
CALL GETRDT
CAIA
MOVEI 1,ORGRDT
EXCH 1,2
CALL RTCPY
RET
; READTABLEP(RDTBL)
RDTBLP: CALL CKRDTS ;USER ENTRY FOR READTABLEP
JRST FALSE
RET
CKRDTS: LDT 4,1 ;SKIP RETURN IF A READTABLE
CAIE 4,ARRAYT ;ARRAY?
RET ;NO
HRRZ 4,(1) ;YES - RIGHT LENGTH?
CAIE 4,RTSIZE+2
RET ;NO
HRRZ 4,1(1) ;YES - CORRECT NUMBER OF UNBOXED WORDS?
CAIE 4,RDNUBW+2
RET
IFN RDCKWD,<
SKIPN RTSIZE+1(1) ;CHECK BOXED CHECK WORD FOR ZERO
>
AOS (CP) ;YES
RET ;NO
; SET INPUT READTABLE FROM AC 2, ACS 1 AND 4 ARE CHANGED
IRTSET: MOVE 1,CURRT2
CAMN 2,KNIL ;CURRENT TABLE?
JRST IRTST1 ;YES
MOVE 1,SYSRT2 ;NO
CAMN 2,KT ;SYSTEM TABLE?
JRST IRTST1 ;YES
MOVEI 1,(2) ;NO
CAMN 1,PRVIRT ;SAME TABLE AS LAST TIME?
JRST IRTST1-1 ;YES
CALL CKRDTS ;IS IT A READTABLE?
ERROR1 46,R ;NO
MOVEM 1,PRVIRT ;YES, SAVE FOR NEXT TIME
ADD 1,[Z RDNUBW+2(1)] ;CONVERT TO INTERNAL USABLE FORM
IRTST1: MOVEM 1,BSTAB ;STORE IT
RET
; SET OUTPUT READTABLE FROM AC 3, ONLY AC 2 IS CHANGED
ORTSET: MOVE 2,CURRT2
CAMN 3,KNIL ;CURRENT TABLE?
JRST ORTST1 ;YES
MOVE 2,SYSRT2 ;NO
CAMN 3,KT ;SYSTEM TABLE?
JRST ORTST1 ;YES
CAMN 3,PRVORT ;SAME TABLE AS LAST TIME?
JRST ORTST2 ;YES
PUSH PP,1 ;NO
PUSH PP,4
MOVEI 1,(3)
CALL CKRDTS ;IS IT A READTABLE?
ERROR1 46,R ;NO
MOVEM 1,PRVORT
ADD 1,[Z RDNUBW+2(1)] ;YES, CONVERT TO INTERNAL USABLE FORM
MOVE 2,1
POP PP,4
POP PP,1
ORTST1: MOVEM 2,PBTAB ;STORE IT
RET
ORTST2: ADD 3,[Z RDNUBW+2(1)]
MOVEM 3,PBTAB
RET
;SET SYSTEM TERM TABLE TO ORIGINAL FOR CURRENT OPERATING SYSTEM
ITTYTB: HRRZ 1,KORIG
CALL CPYTT
JRST TRMTBL ;THIS HERE JRST IS REMOVABLE
;TERMINALTABLE(TABLE)
TRMTBL: CAME 1,KNIL ;IS IT NIL?
JRST .+3 ;NO
GTTY2: HRRZ 1,TTYTBL ;YES - RETURN CURRENT TABLE
RET
CALL CKTRMT ;NO - MAKE SURE IT IS VALID
ERROR1 47,TRMTBL
EXCH 1,TTYTBL ;SET NEW TABLE
TTCP2: PUSH PP,1
CALL SETMOD ;RESET MODES
POP PP,1 ;RETURN OLD VALUE
RET
CKTRMT: LDT 4,1 ;SKIP RETURN IF A TERMINAL TABLE
CAIE 4,ARRAYT ;ARRAY?
RET ;NO
HRRZ 4,(1) ;RIGHT LENGTH?
CAIE 4,TTYSIZ+2
RET ;NO
HRRZ 4,1(1) ;YES - ARE THEY ALL UNBOXED?
CAIN 4,TTYSIZ+2
AOS (CP) ;YES
RET ;NO
; COPYTERMTABLE(TABLE)
CPYTT: CALL OTTBL
PUSH PP,1
CALL TTALOC
POP PP,2
JRST TTCPY
; GETTERMTABLE(TABLE)
OTTBL: CAME 1,KORIG ;GET DESIRED TERMINAL TABLE
JRST OTTBL1
MOVEI 1,ORGTTX
SKIPE KL20F
OTTBL2: MOVEI 1,ORGTT2
RET
OTTBL1: CAME 1,KTENEX
JRST OTTBL3
MOVEI 1,ORGTTX
RET
OTTBL3: CAMN 1,KTOP20
JRST OTTBL2
;NONE OF ABOVE - FALL INTO GETTERMTABLE
GETTY: CAMN 1,KNIL
JRST GTTY2
CALL CKTRMT
ERROR1 47,TRMTBL
RET
; RETSETERMTABLE(TABLE,orig/TABLE)
RSTTBL: CALL GETTY
EXCH 1,2
CALL OTTBL ;GET TABLE SPECIFIED BY SECOND ARG
EXCH 1,2
JRST TTCPY
TTALOC: MOVEI 1,TTYSIZ+2 ;ALLOCATE A TERMINAL TABLE
CALL ALLOC1
MOVEI 2,TTYSIZ+2
HRRM 2,1(1)
RET
TTCPY: PUSH PP,1 ;COPY A TERM TABLE
HRL 1,2
ADD 1,BHC+2
MOVEI 4,TTYSIZ-1(1)
BLT 1,(4)
POP PP,1
CAMN 1,TTYTBL
JRST TTCP2
RET
;TERMTABLEP(TABLE)
TTTBLP: CALL CKTRMT
JRST FALSE
RET
; INREADMACROP()
INRMP: TRNN F,RMFLG ;IS THERE A BLIP?
JRST FALSE ;NO
CALL RLOOK ;FIND READ BLIP
JRST FALSE ;NONE
JUMPE 1,FALSE ;RETURN NIL IF OFF
SUBI 3,3 ;COUND # OF LEVEL THE READ WAS AT
SETZ 1,
SKIPGE @2 ;DONE?
JRST .+3 ;YES
SUBI 3,2 ;NO, STEP TO NEXT
AOJA 1,.-3 ; AND BUMP COUNT
MOVEI 1,ASZ(1)
RET
; SETREADMACROFLG(FLG)
SRMF: CALL RLOOK ;GET READ BLIP
JRST FALSE ;NONE
HRRZ 4,1(VP) ;GET NEW VALUE
CAMN 4,KNIL
SKIPA 4,[0]
SETO 4,
HRRM 4,@2 ;SET READ BLIP NEW VALUE
JUMPE 1,FALSE ;RETURN PREVIOUS VALUE
JRST TRUE
;READ
READX: MOVE 1,KT ;EVALQUOTE READ
HRRZ 2,KT
HRRZ 3,KNIL
READ: TLZ F,NCRFLG
CAME 3,KNIL
TLO F,NCRFLG
CALL IFSET
CALL IRTSET
TRNE F,RMFLG ;READ BLIP?
JRST RD9 ;YES
XREAD: MOVSI 1,-1 ;TOP LEVEL FLAG
JRST XRD1
RD9: TRZ F,RMFLG+RDMFLG ;CLEAR FLAGS
CALL RLOOK ;LOOK FOR READ BLIP
JRST XREAD ;NOT FOUND
SKIPE 1 ;BLIP VALUE 0?
TRO F,RDMFLG ;NO - SET FLAGS
TRO F,RMFLG
JRST XREAD
; SEARCH FOR READ BLIP, SIMILAR TO FNDEVL
RLOOK: MOVE 1,CF
RLOOK5: GETPPI 2,1
MOVEI 3,0(PP)
SUBI 3,0(2)
JUMPE 3,RLOOK2
HRLI 2,3
RLOOK3: HLRZ 4,@2
CAIN 4,READ
JRST RLOOK4
SOJG 3,RLOOK3
RLOOK2: GETCL 1,1
JUMPN 1,RLOOK5
RET
RLOOK4: HRRZ 1,@2
AOS (CP)
RET
;READ TO RIGHT BRACKET
X2READ: CALL X1READ ;READ TO TERMINATOR
XRR: HRRZ 2,FCHAR(FX) ;CHECK TERMINATOR
ADD 2,BSTAB
HLRZ 2,(2)
ANDI 2,JPBITS
CAIN 2,1 ;WAS RIGHT BRACKET?
HLLOS FCHAR(FX) ;YES, CLEAR
RET
;READ TO TERMINATOR
X1READ: MOVEI 1,0
XRD1: PUSH PP,1 ;FLAG,,DOTTED PAIR POINTER
PUSH PP,BHC ;WHOLE LIST,,LAST OF LIST
PUSH CP,XRR1
RD1: CALL RDA ;READ ATOM OR BREAK CHAR
JRST RD5 ;NOT BREAK CHAR
LDB 3,JMPFLD ;JUMP ON BREAK CHAR. TYPE
JRST @RDJTAB(3)
RDJTAB: RDS ;SELF-DELIMITING CHAR.
RDRB ;]
RDLB ;[
RDL ;(
RDR ;)
RDMAC ;ELEMENT READ MACRO
RDMAC ;SPLICE READ MACRO
RDMAC ;INFIX READ MACRO
RDMAC: SKIPN RMONF
JRST RDBQ2 ;NO-READMACROS, JUST A NUMBER
PUSH CP,RDAX ;SAVE I/O ROUTINE ADDRESS
PUSHN 3,3 ;SAVE CURRENT READTABLE
PUSH CP,FX ;PREVIOUS INST. SET US UP FOR 3 NUMBERS
PUSH CP,F
PUSH PP,BSTAB ;SAVE CURRENT READTABLE
PUSH PP,[READ,,1] ;PUT READ BLIP ON STACK
TRO F,RMFLG ;SET BLIP FLAG
TRZ F,RDMFLG ;TURN OFF READMACRO FLAG
HRLM 1,FILEA(FX)
HRRZ 1,@BSTAB
PUSH PP,1
HRRZ 1,FILEA(FX)
PUSH PP,1 ;THE FILE NAME IS 1ST ARG
HRRZ 1,BSTAB ;READTABLS IS 2ND ARG
SUBI 1,RDNUBW+2
PUSH PP,1
MOVEI 1,2
CAIE 3,7 ;IS IT AN INFIX MACRO?
JRST RDMAC2 ;NO
HLRZ 1,-5(PP) ;YES - BUILD A TCONC LIST
SKIPN 1
MOVE 1,KNIL
HRRZ 2,-5(PP)
SKIPN 2
MOVE 2,KNIL
SKIPL -6(PP) ;JUST PASS NIL IF TOPLEVEL READ
CALL CONS
PUSH PP,1
MOVEI 1,3
RDMAC2: CALL EVCC ;CALL THE USER'S FUNCTION
SUB PP,BHC+1 ;REMOVE READ BLIP
POP PP,BSTAB ;RESTORE READTABLE
MOVE 2,F ;GET LBFFLG, RASFLG, AND GCHDQF BITS
AND 2,[LBFFLG+RASFLG,,GCHDQF]
POP CP,F ;GET OLD FLAG BITS
TLZ F,LBFFLG+RASFLG ;PUT IN CURRETN LINBUF AND RASFLG
TRZ F,GCHDQF ;... AND GCHDQF
IOR F,2
POP CP,FX
MOVEM FX,FRX ;ALSO RESET FRX WHO IS USED BY FIN4
POPN 3
POP CP,RDAX ;RESTORE I/O ROUTINE ADDRESS
JRST @RDJMP-5(3)
RDJMP: RDEMAC ;ELEMENT READMACRO
RDSMAC ;SPLICE READMACRO
RDINFX ;INFIX READMACRO
;ELEMENT READMACRO
RDEMAC: SKIPL -1(PP) ;TOP LEVEL?
JRST RD7 ;NO, GO ADDO TO LIST
TRNE F,RDMFLG ;IN A READMACRO?
RET ;YES
HLRZ 2,FILEA(FX) ;NO, IS LASTC()=PEEKC()?
HRRZ 3,FCHAR(FX)
CAIN 2,(3)
JRST XRR ;YES, MIGHT BE A ] THAT NEEDS CLEARING
RET ;NO, EVEN IF PEEK=] IT SHOULD STAY,
; IE, IT'S THERE 'CAUSE OF RDA - 'A]
;SPLICE MACRO
RDSMAC: HRRZ 2,0(PP) ;LCONC RESULT INTO LIST
JUMPE 2,RDSM2 ;WAS NONE
HRLM 1,0(2) ;SMASH IN RESULT
RDSM3: CDRA 1,2 ;GET TAIL
CAMN 1,KNIL ;NULL>
JRST RDSM4 ;YES
LDT 3,1 ;NO - IS IT A LIST
CAIE 3,LISTT
JRST RDSM5 ;NO
MOVEI 2,0(1) ;YES - STEP TO NEXT WORD
JRST RDSM3
RDSM4: HRRM 2,0(PP) ;SAVE THE LAST
JRST RD1 ;AND CONTINUE READING
RDSM2: LDT 3,1 ;NOTHING BUILT YET - RESULT A LIST?
CAIE 3,LISTT
JRST RD1 ;NO
HRLM 1,0(PP) ;YES - SET UP WHOLE LIST
MOVEI 2,0(1)
JRST RDSM3 ;AND GO FIND THE TAIL
RDSM5: HRRM 2,-1(PP) ;MAKE IT LOOK LIKE IT WAS READ
MOVE 2,KNIL
CALL CONS
HRRM 1,0(PP) ;THIS IS THE NEW TAIL
MOVEI 2,0(1)
MOVE 1,KPER
CALL CONS
HRRZ 2,-1(PP)
HRLM 1,(2) ;ATTACH IT INTO TAIL
JRST RD1 ;AND CONTINUE READING
;INFIX MACRO
RDINFX: SETZM 0(PP)
LDT 2,1 ;IS RESULT A LIST?
CAIE 2,LISTT
JRST RD1 ;NO - EMPTY TCONC PAIR, IGNORE
CDRA 2,1 ;YES - THIS BECOMES NEW LIST
SETZM 0(PP)
CAMN 2,KNIL ;RESULT A NIL LIST?
JRST RD1 ;YES
HRRM 2,0(PP)
CARA 2,1
HRLM 2,0(PP)
SKIPL -1(PP) ;TOP LEVEL?
JRST RD1 ;NO - KEEP READING
HLRZ 1,0(1) ;YES
CAIN 1,(2) ;1 ELEMENT LIST?
HRRZ 1,0(1) ;YES, RET THE 1 ITEM, THIS IS PROBABLY
; WHAT THE USER INTENDED
RET
RDBQ2: HRLM 1,FILEA(FX) ;SAVE LAST CHAR
CALL PAC ;SELF-DELIMITING CHARACTER
CALL MKATM ;CONVERT TO ATOM
RD2: SKIPGE -1(PP) ;TOP LEVEL?
RET ;YES, RETURN SINGLE S-EXP
RD7: MOVE 2,KNIL ;NO, NCONC TO ACCUMULATED LIST
CALL CONS
HRRZ 2,0(PP) ;LAST OF LIST
JUMPE 2,RD4 ;WAS NONE
HRLM 1,0(2) ;RPLACD LAST WITH NEW
HRRM 1,0(PP) ;UPDATE LAST
JRST RD1
RD4: HRRZM 1,0(PP) ;SETUP WHOLE AND LAST
HRLM 1,0(PP)
JRST RD1
XRR1: XWD 0,.+1
SUB PP,BHC+2 ;FLUSH TEMPS
RET
;[
RDLB: CALL X2READ
JRST RD2
;(
RDL: CALL X1READ
SKIPL -1(PP) ;TOP LEVEL?
JRST RD7 ;NO, GO ADD TO LIST
TRNN F,RDMFLG ;YES - IN A READMACRO?
JRST XRR ;NO, RETURN
RET ;YES - JUST RETURN THE VALUE
;]
RDRB: SKIPL -1(PP) ;TOP LEVEL?
HRRM 1,FCHAR(FX) ;NO, SETUP TO REPROCESS SAME CHAR
;)
RDR: HRLM 1,FILEA(FX) ;SAVE LAST CHAR
SKIPGE -1(PP) ;TOP LEVEL?
TRNN F,RDMFLG ;YES - IN A READMACRO?
JRST RDR2 ;NO
HRRM 1,FCHAR(FX) ;YES - BACKUP CHAR INCASE USER HAS
;... A NLSETQ. WE WILL THEN WANT TO
;... BE ABLE TO GET IT AT A HIGHER LEVEL
ERROR0 45,R ;ERROR, TRIED TO READ ) OR ]
RDR2: HRRZ 2,-1(PP) ;PERIOD ENCOUNTERED BEFORE?
JUMPN 2,RDP1 ;YES
RDP2: HLRZ 1,0(PP) ;NO, GET WHOLE LIST
JUMPG 1,.+2 ;WAS NULL?
MOVE 1,KNIL ;YES, RETURN NIL
RET
RDS: MOVE 3,@BSTAB
TLNN 3,STRBIT ;IS IT A "?
JRST RDBQ2 ;NO - SELF DELIMITING CHAR.
CALL RDSTR
JRST RD2
;ATOM
RD5: CAMN 1,KPER ;WAS PERIOD?
TRNE F,RQTFLG ;AND NOT QUOTED?
JRST RD2 ;NO, ORDINARY ATOM
HRRZ 2,0(PP) ;YES, SAVE CURRENT LAST
HRRM 2,-1(PP)
JRST RD2
;FINISH DOTTED PAIR
RDP1: CDRA 3,2 ;IS CDDR OF PREVIOUS LAST
CDRA 3,3 ;EQ TO CURRENT LAST?
HRRZ 1,0(PP)
CAIE 1,0(3)
JRST RDP2 ;NO, TREAT DOT AS ORDINARY ATOM
CARA 1,1 ;YES, PUT SECOND HALF IN PROPER PLACE
HRLM 1,0(2)
JRST RDP2
;READ STRING
RSTRNG: CALL IFSET
CALL IRTSET
TRZ F,LREAD ;USER ENTRY, QUITS ON BRK. OR SEP.
TROA F,RATFLG
RDSTR: TRO F,LREAD
CALL MKSTRS ;SET UP TO STORE
RDSTR2: CALL GCHIN
MOVE 2,@BSTAB
SKIPE ESCONF ;ESCAPES ON
TLNN 2,ESCBIT ;AND IS THIS AN ESCAPE?
JRST RDSTR3
TRO F,RQTFLG
CALL GCHIN
JRST RDSTR1
RDSTR3: TRNN F,LREAD
JRST RDSTR7
TLNE 2,STRBIT ;DOUBLE-QUOTE?
JRST RDSTS2
RDSTR1: CALL MKSTR1 ;STORE CHAR
JRST RDSTR2
RDSTR4:RDSTR7: TLNE 2,BRKBIT ;CHECK FOR BRK OR SEPR
JRST RDSTS1
TLNE 2,SEPBIT
JRST RDSTS
JRST RDSTR1
RDSTS: TRO F,SEPFLG
RDSTS1: HRRM 1,FCHAR(FX)
LDB 1,FREEST
RDSTS2: HRLM 1,FILEA(FX)
MOVE 1,UNP1
JRST MKSP
;RATOM - USED BY READ AND AS FUNCTION
RATOM: CALL IFSET ;USER ENTRY
CALL IRTSET
TRZ F,LREAD
TROA F,RATFLG
RDA: TRO F,LREAD ;LISP READ ENTRY
RAT: TRZ F,CHFLG+RQTFLG+SEPFLG ;INIT RATEST FLAGS
CALL PACS ;INITIALIZE ATOM PACK
RAT1: CALL GCHIN
MOVE 2,@BSTAB
SKIPE ESCONF
TLNN 2,ESCBIT
JRST RAT3 ;ESCAPE OFF OR NOT ESCAPE
TRO F,RQTFLG
CALL GCHIN
JRST RAT4
RAT3: TRNN F,CHFLG ;HAVE A CH YET?
TLNN 2,FRSTBT ;NO, ACT LIKE BRK IF ITS A "FIRST" RM
TLNE 2,BRKBIT
JRST RATB
TLNE 2,SEPBIT
JRST RATS
RAT4: CALL PAC
TRO F,CHFLG
JRST RAT1
RATB: TRNE F,CHFLG
JRST RAT2
TRNE F,LREAD
JRST RSKP ;SKIP ON BREAK FOR LISP READ
RAT7: HRLM 1,FILEA(FX)
RAT6: CALL PAC
JRST MKATM1
RAT2: HRRM 1,FCHAR(FX)
LDB 1,CBUFP
HRLM 1,FILEA(FX)
JRST MKATM1
RATS: TRNE F,CHFLG
JRST RAT2
TRO F,SEPFLG ;FOR WT, SEPARATOR PRECEEDS ATOM
JRST RAT1
READC: CALL IFSET ;USER READC, NO SECOND ARG
CALL PACS
TRZ F,LREAD+RATFLG
CALL GCHIN
JRST RAT7
;CONTROL - MISCELLANEOUS MODES FOR TTY INPUT
CONTRL: EXCH 1,2
CALL GETTY ;GET TERM TABLE
EXCH 1,2
SETZ 3,
SETO 4,
CAMN 1,KNIL
JRST CNTRLN
CAME 1,KT
RET
EXCH 4,LBFLGW(2) ;TURN OFF LINE BUFFER
SKIPN 4
HRRZ 1,KNIL
JRST CNTRL2
CNTRLN: EXCH 3,LBFLGW(2) ;SET TO LINE BUFFER
SKIPE 3
HRRZ 1,KT
CNTRL2: CAME 2,TTYTBL ;CURRENT TABLE?
JRST CNTRL1 ;NO
PUSH PP,1
CALL SETMOD ;SETS MODE ACCORDING TO LBFFLG
POP PP,1
CNTRL1: RET
;ECHOMODE - SETS THE ECHO OF TTY INPUT
ECHMOD: EXCH 1,2
CALL GETTY
EXCH 1,2
MOVE 3,ECHMDW(2)
CAME 1,KNIL
JRST ECHMD1
SETZM ECHMDW(2)
SKIPE 3
MOVE 1,KT
JRST CNTRL2
ECHMD1: SETOM ECHMDW(2)
SKIPN 3
MOVE 1,KNIL
JRST CNTRL2
;MISCELLANEOUS TESTS OF LAST ATOM READ
RATEST: CAMN 1,KNIL
JRST RATT1
CAMN 1,KT
JRST RATT2 ;T- CHECK FOR SEPARATOR
CAIN 1,ASZ+1 ;1- CHECK FOR DOUBLE QUOTE
TRNN F,RQTFLG
JRST FALSE
JRST TRUE
RATT1: TRNE F,CHFLG
JRST FALSE
JRST TRUE ;LAST ATOM WAS BREAK CHAR
RATT2: TRNN F,SEPFLG
JRST FALSE
JRST TRUE ;LAST ATOM PRECEEDED BY SEPARATOR
RAISE: EXCH 1,2 ;GET TERM TABLE
CALL GETTY
HRREI 3,-1 ;DECODE ARG
CAMN 2,KNIL
JRST .+4
CAMN 2,KT
ADDI 3,1
ADDI 3,1
EXCH 3,RASMOD(1) ;SET MODE AND GET PREV.
MOVE 2,KNIL ;CONVERT VAL TO RETURNABLE FORM
JUMPL 3,.+4
SKIPE 3
SKIPA 2,KT
MOVEI 2,ASZ
PUSH PP,2
CAMN 1,TTYTBL ;CHANGING CURRENT TABLE?
CALL SETMOD ;YES
POP PP,1
RET
;PEEK AT NEXT CHARACTER
PEEKC: CALL IFSET
CALL IRTSET
CALL PACS
TRZ F,LREAD+RATFLG
HRRE 1,FCHAR(FX) ;ANY SAVED CHAR?
JUMPGE 1,RAT6 ;YES - USE IT
JUMPE FX,PEEKCT ;HANDLE TTY SPECIAL
PEEKC3: CALL GCHIN ;NO - GET A CHAR
HRRM 1,FCHAR(FX) ;SAVE IT
JRST RAT6 ;AND RETURN IT
IFE TEN50,<
PEEKCT: SKIPG LNBFC ;ANYTHING IN LINEBUFFER
JRST PEEKC2
MOVE 2,LNBFP ;YES - GET IT
ILDB 1,2
JRST PEEKC5
PEEKC2: HRRZ 1,2(VP)
CAME 1,KNIL
JRST PEEKC4
MOVEI 1,100 ;WAKEUP ON EVERYTHING
RFMOD
MOVEM 2,OLDMOD
TRO 2,10000
SFMOD
HRRZ 1,FILEN(FX)
BIN
CAIN 2,15 ;IF CR WE WILL ASSUME EOL FROM TTY
MOVEI 2,EOL
MOVEI 4,0(2)
MOVEI 1,100 ;RESET WAKEUP
MOVE 2,OLDMOD
SFMOD
HRRZ 1,FILEN(FX)
BKJFN ;BACK UP
ERROR0 20,RESET ;??? WHAT DOES BAD RETURN MEAN
MOVEI 1,0(4)
PEEKC5: TLNN F,RASFLG ;RAISE MODE?
JRST RAT6 ;NO
CAIL 1,"a" ;IS IT A LOWER CASE LETTER
CAILE 1,"z"
JRST RAT6 ;NO
TRZ 1,40 ;YES - MAKE UPPER CASE
JRST RAT6
PEEKC4: TRO F,LREAD
JRST PEEKC3
>
LASTC: CALL IFSET
CALL PACS
HLRZ 1,FILEA(FX)
CALL PAC
JRST MKATM
EOFP: CALL IFSET
JUMPE FX,FALSE ;TTY IS NEVER AT EOF
HRRE 1,FCHAR(FX) ;ANY SAVED CHAR?
JUMPGE 1,FALSE ;IF SO - NIL
HRRZ 1,FILEN(FX) ;GET JFN
BIN
JUMPN 2,EOFP2 ;THE CHAR IS THERE, NIL
GTSTS ;COULD BE EOF - CHECK STATUS
TLNN 2,1B26
SKIPA 2,[0] ;NOT EOF - RESTORE THE NULL
JRST TRUE ;END OF FILE
EOFP2: BKJFN ;NOT EOF. THIS IS BETTER THAN PUTTING IN FCHAR
JFCL ;BECAUSE IT AVIODS THE CR/LF -> EOL PROBLEMS
JRST FALSE
;GET CHARACTER FROM CURRENT INPUT FILE
GCHIN: HRRE 1,FCHAR(FX) ;ANY SAVED CHAR?
JUMPL 1,@RDAX ;NO, GO GET INPUT
HLLOS FCHAR(FX)
RET
GCHIT: SOSGE LNBFC ;TELETYPE - CHARS LEFT IN BUFFER?
CALL GCHIA ;NO, GO FILL IT
GCHI1: ILDB 1,LNBFP ;YES, GET NEXT ONE
TLNN F,RASFLG ;INTERNAL RAISE?
RET ;NO
CAIL 1,"a" ;YES - LOWER CASE LETTER?
CAILE 1,"z"
RET ;NO
TRZ 1,40 ;YES, MAKE UPPER CASE
RET
;FILL TTY LINE BUFFER, PERFORMING EDITING
GCHIB: TRO F,LREAD
TLOA F,BKFLG ;ENTRY TO FILL FROM STRING
GCHIA: TLZ F,BKFLG ;NORMAL ENTRY
GCHI2: SETZM LNBFC ;COUNT
TRNE F,LREAD+RATFLG ;LISP READ OR RATOM ?
JRST GCHI7 ;YES
TLNN F,LBFFLG
JRST GCHI7
AOS 0(CP) ;SO THAT WE DO INTERNAL RAISE
CALL FIN1 ;UN LINE BUFFERED READC, GET CHAR
SKIPE 3,DRIBFX ;DRIBBLING?
SKIPE DRIBVB ;AND NOT VERBOSE
RET ;NO
HRRZ 2,TTYTBL ;ECHOING INPUT?
SKIPN ECHMDW(2)
RET ;NO
EXCH 3,FX ;DRIBBLE THE CHAR
CALL FOUT
EXCH 3,FX
RET
GCHI7: PUSH CP,PARENC
PUSH CP,BRKCT
PUSH CP,F ;SAVE VALUES FOR POSSIBLE LINE DELETE
MOVE 7,[POINT 7,LNBF,-1] ;INITIAL POINTER
MOVEM 7,LNBFP
JRST GCHI4
FIXCTA: MOVEI 1,100 ;TURN OFF ↑A MODE
MOVE 2,INCTLA ;BY RESETING TTY MODE
SFMOD
SETZM INCTLA
RET
GCHI5: AOS LNBFC ;COUNT CHARACTER JUST ADDED
GCHI4: TLNE F,BKFLG
JRST GCHIB1
CALL FIN1 ;GET NEXT CHAR FROM TTY
GCHIB2: IDPB 1,7 ;PUT INTO BUFFER
HRRZ 2,TTYTBL ;SEE IF A SPECIAL FORMAT CHARACTER
CAMN 1,CTLQ(2)
JRST GCHQ ;↑Q
CAMN 1,CTLR(2)
JRST GCHR ;↑R
CAMN 1,CTLA(2)
JRST GCHA ;↑A
SKIPN INCTLA ;IN A ↑A LOOP?
JRST GCHIB7 ;NO
PUSH PP,1 ;YES
HRRZ 1,TTYTBL
HRROI 1,CAMSGP(1) ;PRINT THE POST MESSAGE
CALL GCHMSG
CALL FIXCTA ;LEAVE ↑A MODE
POP PP,1
HRRZ 2,TTYTBL
SKIPE ECHMDW(2) ;ECHOING INPUT?
CALL TCO1 ;YES - ECHO THE CHAR
HRRZ 2,TTYTBL
SETZM INCTLA ;NO LONGER IN ↑A MODE
GCHIB7: CAMN 1,CTLV(2)
JRST GCHV ;↑V
CAMN 1,CTLEOL(2)
JRST GCHE ;EOL
GCHI3A: CAMN 7,[POINT 7,LNBF+LLNBF-1,34]
JRST GCHE ;FULL , ACT LIKE EOL
JRST GCHLC ;NOT SPECIAL, CHECK LISP FORMATTERS
GCHIB1: CALL BKCHAR ;GET CHAR FROM STRING
JRST GCHE1 ;NO MORE - QUIT
IDPB 1,7
JRST GCHLC ;ASSUME CANT GET SPECIAL CHARS HERE
GCHE1: SUB CP,BHC+3
RET
GCHE: SUB CP,BHC+3
GCHE2: SKIPE 3,DRIBFX ;DRIBBLING?
SKIPE DRIBVB ;AND NOT VERBOSE
RET ;NO
HRRZ 2,TTYTBL ;ECHOING?
SKIPN ECHMDW(2)
RET ;NO
MOVE FX,3 ;SET UP TO OUTPUT LINE
MOVE 3,LNBFP ;GET THE BYTE POINTER
GCHE0: ILDB 1,3
CALL FOUT ;DRIBBLE A CHARACTER
CAME 3,7 ;DONE?
JRST GCHE0 ;NO
MOVE FX,FRX ;YES
RET
GCHQ: SKIPE INCTLA
CALL FIXCTA
HRRZ 2,TTYTBL
HRROI 1,CTQMSG(2)
GCHA1A: CALL GCHMSG
POP CP,F
POP CP,BRKCT ;RESTORE VALUES TO BEG OF LINE
POP CP,PARENC
JRST GCHI2
GCHA: HRRZ 2,TTYTBL
SOSGE LNBFC ;CHARACTERS TO DELETE?
JRST GCHA1 ;NO
SKIPN INCTLA ;1ST ↑A?
JRST GCHA2 ;YES
HRROI 1,CAMSG2(2) ;NO - USE OTHER MESSAGE
GCHA3: CALL GCHMSG
IBP 7 ;BACKUP POINTER 2
IBP 7
IBP 7
SOS 3,7 ;LEAVING NEW VALUE IN AC2 ALSO
ILDB 1,3 ;CHARACTER TO BE DELETED
SKIPN ECHFLG(2) ;ECHOING DELETED CHAR
SKIPN ECHMDW(2) ;... AND TYPEIN?
CAIA ;NO
CALL TCO1 ;TYPE IT OUT
JRST GCHDC ;CHECK FOR LISP FORMATTERS
GCHA2: MOVEI 1,100 ;ENTER ↑A MODE
RFMOD
MOVEM 2,INCTLA
TRZ 2,6000 ;TURN OFF ECHO
TRO 2,170000 ;WAKE UP ON EVERYTHING
SFMOD
HRRZ 2,TTYTBL
HRROI 1,CAMSG1(2) ;FIRST ↑A MESSAGE
JRST GCHA3
GCHA1: HRROI 1,CAMSGE(2) ;PRINT EMPTY BUFFER MESSAGE
JRST GCHA1A
GCHR: SKIPE INCTLA ;CLEAR ↑A MODE
CALL FIXCTA
MOVEI 1,EOL ;RETYPE LINE, EOL FIRST
CALL TCO1
ADD 7,[7B5] ;BACKUP POINTER 1 TO FLUSH R
MOVE 6,LNBFP ;INITIAL POINTER
MOVE 5,LNBFC ;CURRENT COUNT
GCHR1: JUMPE 5,GCHI4 ;DONE
ILDB 1,6
CALL TCO1
SOJA 5,GCHR1
GCHV: CALL CTRLV ;GET CHAR UNDER THE ↑V
DPB 1,7 ;STORE ON TOP OF CTRLV
JRST GCHI5
CLRTTY: SETZM LNBFC
SETZM PARENC
SETZM BRKCT
HLLOS FCHAR ;CLEAR SINGLE CHARACTER BUFFER
TRZ F,GCHDQF
RET
GCHMSG: PUSH CP,2 ;FAST OUTPUT TO TTY
MOVE 2,1 ;MAKE UP THE BYTE POINTER
HRLI 2,440700
GCHM1: ILDB 1,2 ;GET A CHAR
JUMPE 1,GCHM3 ;DONE?
SKIPN DRIBFX ;VERBOSE DRIBBLE CHECK
JRST .+3 ;
SKIPE DRIBVB ;
JRST GCHM4 ;
CAIE 1,EOL ;NO, EOL?
JRST GCHM2 ;NO
MOVEI 1,15 ;YES, MAKE INTO CRLF
PBOUT
MOVEI 1,12
GCHM2: PBOUT ;OUTPUT THE CHAR WITHOUT DRIBBLING
JRST GCHM1 ;GO BACK FOR NEXT CHAR
GCHM3: MOVEI 1,101 ;NOW GET THE LINE POSITION
RFPOS ;WILL BE CORRECT EVEN IF THINGS
HRRZM 2,CHPOS+1 ;... LIKE ↑H ARE BACKSPACING
POP CP,2
RET
GCHM4: MOVEI FX,1 ;DRIBBLE THE CHAR ANYWAY
CALL FOUT
MOVE FX,FRX
JRST GCHM1
TCO1: MOVEI FX,1 ;OUTPUT TO TTY: WITHOUT DRIBBLING
SKIPE DRIBFX ;VERBOSE DRIBBLE CHECK
SKIPN DRIBVB ;
JRST .+4
CALL FOUT ;DRIBBLE CHAR ANYWAY
MOVE FX,FRX
RET
CALL CHACCT
MOVE FX,FRX
CAIE 1,EOL
JRST TCO1A
MOVEI 1,15 ;CONVERT EOL TO CR,LF
PBOUT
MOVEI 1,12
PBOUT
SKIPA 1,[EOL] ;RESTORE EOL TO AC1
TCO1A: PBOUT
RET
U DRIBFX ;CONTAINS THE INDEX OF THE DRIBBLE FILE
U DRIBVB ;DRIBBLE VERBOSE FLAG
U PARENC
U BRKCT
U LNBFP
U LNBFC
LLNBF==40
U LNBF,LLNBF
U SLNBF,LLNBF ;BUFFER FOR SAVED LINE BUFFER
U INCTLA ;IN ↑A MODE FLAG
U RDAX
;SPECIAL LINE EDITING FOR LISP FORMAT CHARACTERS
GCHLC: TRNN F,LREAD+RATFLG
JRST GCHI5 ;NOT LISP READ OR RATOM
MOVE 2,@BSTAB
SKIPN ESCONF
JRST .+3
TLNE 2,ESCBIT
JRST GCHESC
TRNN F,LREAD
JRST GCHL1
TLNE 2,STRBIT ;DOUBLE QUOTE?
JRST GCHDQ
TRNE F,GCHDQF ;INSIDE DOUBLEQUOTE NOW?
JRST GCHI5 ;YES
TLNE 2,IMEDBT ;IS IT AN "IMEDIATE" READMACRO?
JRST GCHE ;YES, ACT LIKE EOL
LDB 2,JMPFLD
JRST @GCHJMP(2)
GCHJMP: GCHL3
GCHRBK ;]
GCHLBK ;[
GCHLPR ;(
GCHRPR ;)
GCHL3
GCHL3
GCHL3
GCHL3: TLNN F,LBFFLG ;LINE-BUFFERRED?
JRST GCHI5 ;YES - GO ON
SKIPN BRKCT ; NO - CHECK BRACKET AND PAREN COUNTS
SKIPE PARENC
JRST GCHI5 ;INSIDE LIST - GO ON
JRST GCHL2 ;GO CHECK FOR BREAK AND SEPR
GCHLPR: SKIPN BRKCT
AOS PARENC
JRST GCHI5
GCHRBK: SOSLE 1,BRKCT
JRST GCHI5
JUMPL 1,GCHACR ;UNMATCHED RIGHT BRACKET
SKIPLE PARENC
JRST GCHI5
GCHRPR: SKIPN BRKCT
SOSLE PARENC ;COUNT DOWN PARENS
JRST GCHI5
GCHACR: SETZM PARENC ;TERMINATOR
SETZM BRKCT
TLNE F,NCRFLG
JRST GCHE
CALL GCHE2 ;MAKE SURE BUF IS DRIBBLED FIRST
TMSG EOLM ;NOW DO THE EOL
JRST GCHE1
GCHLBK: AOS BRKCT
JRST GCHI5
GCHDQ: TRCE F,GCHDQF
JRST GCHL3 ;CLOSING QUOTE, CHECK IF WANT TO QUIT
JRST GCHI5
GCHESC: AOS LNBFC ;ESCAPE COMING ON, QUOTE ONE CHAR
TLNE F,BKFLG
CALL BKCHAR ;GET CHAR FROM STRING -IF EMPTY,READ
CALL FIN1
HRRZ 2,TTYTBL
CAMN 1,CTLV(2) ;CONTROL-V?
CALL CTRLV
GCHES1: IDPB 1,7
JRST GCHI5
GCHL1: TLNN F,LBFFLG ;HERE IF RATOM
JRST GCHI5 ;LIN BUFFERRED, GO TO EOL
GCHL2: MOVE 2,@BSTAB ;NOT LINE BUFFERED, BRK OR SEPR?
TLNE 2,BRKBIT+SEPBIT
JRST GCHE ;YES, QUIT
JRST GCHI5 ;YES
CTRLV: TLNE F,BKFLG ;READING FROM STRING?
RET ;YES-PASS ↑V THRU
CALL FIN1 ;GET ANOTHER CHAR
CAIG 1,"z"
CAIN 1,100
RET ;IGNORE @
CAIL 1,"a"
TRZ 1,40 ;UPPER SHIFT
CAIGE 1,133
ANDI 1,77 ;TRANSFORM A-Z TO ↑A-↑Z
RET ;ALL ELSE UNCHANGED
;ACCOUNT FOR DELETED CHARACTER
GCHDC: SKIPLE 4,LNBFC ;ANYTHING IN BUFFER?
SKIPN ESCONF
JRST GCHDC1
TRZ F,ESCFLG
GCHDC3: UBP 3 ;BACK UP POINTER
LDB 5,3 ;...LOOK FOR ODD OR EVEN ESC
EXCH 1,5
MOVE 1,@BSTAB
EXCH 1,5
TLNN 5,ESCBIT
JRST GCHDC2
TRC F,ESCFLG
SOJG 4,GCHDC3
GCHDC2: TRZN F,ESCFLG
JRST GCHDC1
IBP 7 ;CHAR IS UNDER ESC. DELETE ESC. ALSO
JRST GCHA
GCHDC1: TRNN F,LREAD
JRST GCHI4
MOVE 2,@BSTAB
TLNE 2,STRBIT
TRC F,GCHDQF
TRNE F,GCHDQF
JRST GCHI4 ;WITHIN DOUBLEQUOTE
LDB 2,JMPFLD
XCT GCHDC4(2)
GCHDC4: JRST GCHI4
AOS BRKCT ;]
SOS BRKCT ;[
JRST GCHDC5 ;(
JRST GCHDC6 ;)
JRST GCHI4
JRST GCHI4
JRST GCHI4
GCHDC5: SKIPN BRKCT ;NO COUNTING INSIDE BRACKETS
SOS PARENC
JRST GCHI4
GCHDC6: SKIPN BRKCT
AOS PARENC
JRST GCHI4
;INITIALIZE ATOM PACKER
PACS: PUSH CP,1
SETZM POCT
SETZM PDEC
TRZ F,NEGFLG+LETFLG+QFLG+DIGFLG+FLTFLG
PACS2: MOVN 1,MAXATL
MOVEM 1,NICHRS
ADDI 1,4
IDIVI 1,5
ADD 1,ENDPN
CAML 1,FREEPN
JRST PACS1
MOVEI 1,PNAMT
PUSHJ GP,GC1 ;RECLAIM
HRRZ 1,TYPBLK+PNAMT
HRRZ 1,TNFR(1)
IMULI 1,5
CAIL 1,NATMC ;ENUF NOW?
MOVEI 1,NATMC ;YES - RESET MAXATL TO ORIG. VALUE
MOVEM 1,MAXATL ;NO - MAKE MAXATL SHORTER
CAIL 1,NATMC
JRST PACS2
JRST RESET ; AND GO TO TOP
PACS1: MOVE 1,FREEPN
HRLI 1,350700
MOVEM 1,CBUFP
MOVEM 1,SCBUFP
POP CP,1
RET
U POCT ;ACCUMULATES OCTAL NUMBER
U PDEC ;ACCUMULATES DECIMAL NUMBER
U CBUFP ;CURRENT POINTER TO PACKED STRING
U SCBUFP ;INITIAL POINTER TO PACKED STRING
U NICHRS ;COUNT OF CHARACTERS IN ATOM
;ACCUMULATE CHARACTER FOR ATOM
PAC: IDPB 1,CBUFP
TRNE F,LETFLG+QFLG
JRST PACL
CAIN 1,"E"
TRNN F,DIGFLG
CAIN 1,"."
JRST PACFI
CAIN 1,"-"
JRST PACM
CAIN 1,"+"
JRST PACP
CAIN 1,"Q"
JRST PACQ
CAIL 1,"0"
CAILE 1,"9"
JRST PACL
TRO F,DIGFLG
SUBI 1,"0"
MOVE 2,POCT
LSH 2,3
IORI 2,0(1)
MOVEM 2,POCT
MOVE 2,PDEC
LSH 2,2
ADDB 2,PDEC ;TIMES 5
ADDM 2,PDEC ;TIMES 10
ADDM 1,PDEC
JRST PACOUT
PACQ: TRNE F,FLTFLG
JRST PACL
TROA F,QFLG
PACFI: TRO F,FLTFLG
JRST PACOUT
PACM: TRO F,NEGFLG
PACP: TRNN F,FLTFLG
TRNN F,DIGFLG
JRST PACOUT
PACL: TRO F,LETFLG
PACOUT: AOSL NICHRS
ERROR0 13,RESET ;ATOM TOO LONG
RET
;MAKE ATOM
MKATM: TRZ F,LREAD ;MAKE SURE LISP READ IS OFF FOR MKAC
MKATM1: TRNN F,LETFLG ;READ AND RATOM ENTRY
TRNN F,DIGFLG
JRST MKAC ;>0 LETTERS OR 0 DIGITS => LITERAL ATOM
TRNE F,FLTFLG ;FLOATING NUMBER?
JRST MKFLT ;YES
MOVE 1,PDEC
TRNE F,QFLG ;OCTAL NUMBER
MOVE 1,POCT ;YES
TRNE F,NEGFLG ;MINUS SIGN?
MOVN 1,1 ;YES, NEGATE
JRST MKN
MKAC: MOVE 1,MAXATL
ADDB 1,NICHRS
CAIE 1,1 ;ONE-CHARACTER ATOM?
JRST MKAL ;NO
TRNE F,LREAD ;YES, IN LISP READ
TRNE F,RQTFLG ; AND NOT QUOTED?
JRST MKAL ;NO
HLRZ 1,FILEA(FX) ;YES, GET THE 1 CHAR.
MOVE 2,@BSTAB
TLNE 2,ALONBT ;IS IT AN "ALONE" READMACRO?
JRST RSKP ;YES, ACT LIKE RATOM HAD A BRK CHAR.
MOVEI 1,1 ;NO, RESTORE COUNT
JRST MKAL ; AND MAKE THE ATOM
;TRANSFORM CHARACTER STRING INTO FLOATING NUMBER
MKFLT: IFE TEN50,<SETZ 1,
IDPB 1,CBUFP
MOVE 1,SCBUFP
FLIN
JRST MKAC
CAME 1,CBUFP
JRST MKAC ;DIDNT USE ALL CHARS
MOVE 1,2
JRST MKFN
>
IFN TEN50,<MOVE 3,SCBUFP
SETZ 4,
CALL MKFI ;GET INTEGER PART
TRNE F,NEGFLG
MOVN 1,1
MOVE 5,2 ;SAVE TERMINATING CHARACTER
CALL FXFLT ;FLOAT INTEGER
MOVE 4,1
CAIE 5,"." ;IS THERE A FRACTION?
JRST MKFE ;NO- GO DO EXPONENT
MOVE 5,FT01 ;0.1
TRNE F,NEGFLG
MOVNS 5
MKFL1: CAMN 3,CBUFP
JRST MKFLX
ILDB 2,3
CAIN 2,"E"
JRST MKFE
CAIG 2,"9"
CAIGE 2,"0"
JRST MKAC ;REALLY ISNT FLOATING NUM, ATOM
SUBI 2,"0"
MOVSI 2,211000(2) ;FLOAT THE DIGIT
FMPR 2,5
FADR 4,2
FMPR 5,FT01 ;0.1
JRST MKFL1
MKFE: CALL MKFI ;GET EXPONENT
MOVEI 5,FT
TRNE F,NEGFLG
MOVEI 5,FT0
MKFE1: SUBI 5,1
TRNE 1,1
FMPR 4,0(5)
LSH 1,-1
JUMPN 1,MKFE1
MKFLX: MOVE 1,4
JRST MKFN ;BOX IT
MKFI: TRZ F,NEGFLG ;GET INTEGER WITH OPTIONAL SIGN
SETZ 1,
ILDB 2,3
CAIN 2,"-"
TROA F,NEGFLG
CAIN 2,"+"
JRST MKFI2
MKFI1: CAIG 2,"9"
CAIGE 2,"0"
RET ;QUIT ON NON NUMBER
SUBI 2,"0"
IMULI 1,12
ADDI 1,0(2)
MKFI2: CAMN 3,CBUFP
RET ;QUIT ON END BUFFER
ILDB 2,3
JRST MKFI1
>
;CONSTRUCT LITERAL ATOM
MKAL: DPB 1,SCBUFP ;STORE CHAR COUNT AT BEG OF STRING
IDIVI 1,5
MOVE 2,[774000000000
777760000000
777777700000
777777777400
777777777776](2)
ANDM 2,@CBUFP ;CLEAR OUT TRAILING CHARS
HRRZ 1,SCBUFP ;PNAME ADDRESS
CALL HENTER ;LOOKUP NAME IN ATOM HASH TABLE
JRST MKAL1 ;ALREADY PRESENT
MOVEI 7,0(1) ;NEW ENTRY, H.T. ADDRESS IN 1
MKALG1: MOVE 1,FREEAT ;ATOM FREE LIST
JUMPE 1,MKALGC ;NO ATOMS LEFT
MOVE 1,0(1) ;GET NEXT ENTRY IN LIST
EXCH 1,FREEAT ;UPDATE FREE LIST POINTER
MOVE 2,KNIL ;SETUP TOP LEVEL CELLS
HRL 2,KNIL ;NIL=>CAR=>CDR
MOVEM 2,0(1)
HRRI 2,(EXCAL)
MOVSM 2,1(1)
HRLZ 2,SCBUFP ;PNAME POINTER
MOVEM 2,2(1)
AOS 2,CBUFP ;UPDATE PNAME POINTER
HRRZM 2,FREEPN
MOVEI 2,2(1) ;POINTER TO PNAME CELL
HRRM 2,0(7) ;=>HASH TABLE
RET
MKAL1: HRRZ 1,0(1) ;GET POINTER TO ATOM
MOVEI 1,-2(1) ;MAKE IT POINT TO VALUE, NOT PNAM CELL
RET
MKALGC: CALL ATOMGC ;COLLECT ATOMS
JRST MKALG1
EVALUU: EXCAL 0
;PRINT, ETC.
PRINTX: MOVE 2,KT ;PRINT TO TTY
HRRZ 3,KT
PRINT: CALL PRIN2
TCH EOL
RET
PRIN1: TRO F,PMCFLG ;ENABLE MARGIN CHECKING
CALL OFSET
PRIN1A: TLZ F,PDQFLG ;DISABLE ESCAPE
TLO F,PRXFLG ;ENABLE RADIX
JRST IPRE1
PRIN2: TRO F,PMCFLG ;ENABLE MARGIN CHECKING
JRST PRINN
PRIN3: TRZ F,PMCFLG ;DISABLE MARGIN CHECKING
CALL OFSET
PUSHN CHPOS(FX)
CALL PRIN1A
POPN CHPOS(FX)
RET
PRIN4: TRZ F,PMCFLG ;ENABLE MARGIN CHECKING
PUSH PP,3
CALL OFSET
POP PP,3
PUSHN CHPOS(FX)
CALL PRIN2A
POPN CHPOS(FX)
RET
IPRE: TLZ F,PDQFLG+PRXFLG ;DISABLE ESCAPE AND RADIX
HRRZ 3,@KPRXFL ;IF PRXFLG=T - ENABLE RADIX
CAME 3,KNIL
TLO F,PRXFLG
JRST IPRE3
IPRE2: TLO F,PDQFLG+PRXFLG ;INTERNAL PRINT, PRIN2 FORMAT
MOVEM 2,PREX ;INTERNAL SUBR
MOVNI FX,1 ;DENOTES NO FILE
JRST IPRE4
IPRE3: MOVEM 2,PREX ;INTERNAL SUBR
MOVNI FX,1 ;DENOTES NO FILE
JRST IPRE1
PRINN: PUSH PP,3
CALL OFSET
POP PP,3
PRIN2A: TLO F,PDQFLG+PRXFLG
IPRE4: CALL ORTSET
IPRE1: MOVE 2,PPLVL
MOVEM 2,TPLVL
SETZM PLVL
MOVE 2,PPDLVL ;CDR PRINTLEVEL
MOVEM 2,TPDLVL
TLZ F,PRPFLG
HRRZ 2,@KPLFLG
CAMN 2,KNIL
SETZ 2,
CAIN FX,1
SETO 2,
MOVEM 2,PLPFLG ;PLPFLG:=(OR PLVLFLG FX=1)
CALL PRE
RET
PRE: PUSH PP,1
STE 1,LIST
JRST PRE5
HRLM 1,0(PP)
SKIPN PLPFLG ;CHECK PRINTLEVEL?
JRST PRE6 ;NO, DONT CHECK PRINTLEVEL
MOVE 1,TPLVL
CAMG 1,PLVL
JRST PRE4
TLNE F,NEGPLF
TLZN F,PRPFLG
JRST PRE9
TCH EOL
PRE9: SKIPGE PPDLVL ;ARE WE CHECKING THE CDR?
JRST PRE6 ;NO
SKIPG TPDLVL ;ABOUT TO PRINT (--)
JRST PRE4 ;RATHER THAN PRINTING (--)
PRE6: TCHM "("
AOS PLVL
SOS TPDLVL
MOVE 1,PDRLVL
HRLM 1,0(CP)
SETZM PDRLVL ;CLEAR CDR PRINTLEVEL
PRE1: HLRZ 1,0(PP)
STE 1,LIST
JRST PRE2
SKIPL PPDLVL ;<0 MEANS INFINTE CDR PRINTLEVEL
SKIPN PLPFLG ;CHECK PRINTLEVEL?
JRST PRE7 ;NO, DONT CHECK PRINTLEVEL
MOVE 3,TPDLVL
CAMGE 3,PDRLVL ;CHECK CDR PRINTLEVEL
JRST PRE8 ;TOO MANY CDR'S
PRE7: CDRA 2,1
CARA 1,1
HRLM 2,0(PP)
CALL PRE
HLRZ 1,0(PP)
CAMN 1,KNIL
JRST PRE3
CALL SPACE1
AOS PDRLVL
SKIPN PLPFLG ;CHECK PRINTLEVEL?
JRST PRE1 ;NO, DONT CHECK PRINTLEVEL
MOVE 1,TPLVL
CAML 1,PLVL
JRST PRE1
PRE8: TCHM "-"
TCHM "-"
PRE3: TLO F,PRPFLG
TCHM ")"
SOS PLVL
AOS TPDLVL
HLRZ 1,0(CP) ;GET OLD CDR PRINTLEVEL
MOVEM 1,PDRLVL
PREE: POP PP,1
HRRZ 1,1
RET
PRE2: TCHM "."
CALL SPACE1
CALL PRATM
JRST PRE3
PRE4: TCHM "&"
JRST PREE
PRE5: TLZ F,PRPFLG
CALL PRATM
JRST PREE
TCHMQ: PUSH CP,1
JUMPL FX,TCHQ+1 ;REAL FILE?
TRNN F,PMCFLG ;AND CHECK MARGIN
JRST TCHQ+1
HRRZ 1,CHPOS(FX)
JUMPE 1,TCHQ+1
CAMGE 1,LINSIZ ;CHECK LINE LENGTH
JRST TCHQ+1
MOVEI 1,EOL
CALL PREC
SKIPA
TCHQ: PUSH CP,1 ;TYPE ONE QUOTED CHARACTER UUO
HRRZ 1,40
CALL PREC
POP CP,1
RET
U PLPFLG ; "CHECK PRINTLEVEL" FLAG
U PPLVL ;PERMANENT PRINT LEVEL
U TPLVL ;TEMPORARY (THIS PRINT) PRINT LEVEL
U PLVL ;RUNNING PRINT LEVEL
U PPDLVL ;PERMANENT CDR PRINT LEVEL
U TPDLVL ;TERPORAY CDR PRINT LEVEL
U PDRLVL ;RUNNING CDR PRINT LEVEL
SPACE1: PUSH CP,1
JUMPL FX,SPA2 ;REAL FILE?
TRNN F,PMCFLG ;CHECK MARGIN?
JRST SPA2 ;NO
HRRZ 1,CHPOS(FX)
CAML 1,LINSIZ
TCH EOL ;YES, CR
CAMG 1,LINSIZ
SPA2: TCH " " ;NO, SPACE
POP CP,1
RET
SPACES: CALL OFSET
CALL IUNBOX
MOVE FX,FPX
HRRZ 2,CHPOS(FX)
ADD 2,1
CAMLE 2,LINSIZ ;WILL PASS MARGIN?
TCH EOL ;YES, NEW LINE FIRST
JUMPLE 1,FALSE ;NO, OUTPUT AND COUNT SPACES
TCH " "
SOJG 1,.-1
JRST FALSE
;PRINT NON-LIST DATA
PRATM: LDT 2,1
HLRZ 3,EVATAB(2) ;USER PRINTING FN FOR THIS TYPE?
JUMPE 3,PRATM2
CAIE 3,-1
JRST PRUDT ;YES.
PRATM2: CAIN 2,ARRAYT
JRST PRARR ;ARRAY PRINT
CAIN 2,ATOMT
JRST PRAT ;ATOM
CAIN 2,FLOATT
JRST PRFLT ;FLOATING POINT NUMBER
CAIE 2,SMALLT
CAIN 2,FIXT
JRST PRNUM ;INTEGER
CAIE 2,PNAMT
CAIN 2,STPTT
JRST PRSTR ;STRING
CAIN 2,STKPT
JRST PRSTK
PRABAD: MOVEI 4,"#"
MOVEI 3,1
MOVEI 2,10
JRST APTX
PRNUM: CALL IUNBOX
MOVEI 4,0 ;SETUP FOR APT
MOVEI 3,0
MOVE 2,URADIX
TLNN F,PRXFLG
MOVEI 2,12 ;RADIX DISABLED FOR IPRE
JUMPGE 1,PRA2
TLNN F,PNEGF ;SKIP ON PRINT SIGN FOR MINUS
JRST PRA2
MOVN 1,1
ADDI 3,1 ;AN EXTRA CHAR
MOVEI 4,"-" ;PREFIX CHAR IS -
PRA2: CAIN 2,10
TLNN F,PDQFLG
JRST APTX
JUMPL 1,.+3
CAMGE 1,2
JRST APTX
CALL APTX
ADDI 3,1
TCH "Q" ;Q AFTER OCTAL NUM IF PRIN2 AND NUM>7
RET
PRSTK: PUSH PP,1
CALL PRABAD ;PRINT #PTRLOC
TCH "/"
POP PP,1
MOVE 1,0(1)
JUMPE 1,PRABAD ;CONTENTS 0 , PRINT AS #0
GETNAR 2,1
GETBAS 3,1
ADDI 2,1(3)
HRRZ 1,0(2)
JRST PRATM
PRUDT: PUSHN F ;SAVE PRINT STATUS
PUSHN FX
PUSHN PREX
PUSH CP,PBTAB
PUSH PP,1
PUSH PP,3 ;APPLY THE ITEM TO THE FN
PUSH PP,1
MOVEI 1,1
CALL EVCC
POP PP,3
POP CP,PBTAB
POPN PREX
POPN FX ;GET FILE INDEX BACK
STE 1,LIST ;IS RESULT A LIST?
JRST PRUDT2 ;NO, PRINT IN NORMAL FASION.
MOVE F,0(CP) ;GET FLAGS
TLZ F,PDQFLG ;TURNOFF ESCAPE
PUSH PP,1
CARA 1,1
CAME 1,KNIL ;IS CAR NIL?
CALL PRE ;NO, PRINT IT.
POPN F ;RESTORE FLAGS
POP PP,1
CDRA 1,1 ;PRINT THE REST OF THE LIST
JRST PRE
PRUDT2: POPN F
MOVEI 1,(3)
LDT 2,1
JRST PRATM2
;PRINT ATOM
PRAT: CAMN 1,KPER ;PERIOD?
JRST PRAPER ;YES, PRINT WITH DOUBLEQUOTES MAYBE
PRAP2: HLRZ 1,2(1) ;GET PNAME POINTER
PRAST: CALL UPATM ;SETUP BYTE AND COUNT
JUMPE 4,R ;NO CHARS?
JUMPL FX,PRA8 ;REAL FILE?
TRNN F,PMCFLG ;CHECK MARGIN?
JRST PRA8 ;NO
HRRZ 1,CHPOS(FX) ;POSITION ON LINE
JUMPE 1,PRA8
ADDI 1,0(4)
CAMLE 1,LINSIZ ;WILL EXCEED RIGHT MARGIN?
TCH EOL ;YES, CR
PRA8:
PRA5: ILDB 1,3
TLNN F,PDQFLG ;IF ESCAPE DISABLED,
JRST PRA6 ;DO NOT CHECK FOR SPECIAL CHAR
MOVEI 5,0(1)
MOVE 1,@PBTAB
TLNE 1,PRTBIT
TCH ESC ;SO PRINT ESCAPE
PRA7: MOVEI 1,0(5)
PRA6: CALL PREC
SOJG 4,PRA5 ;COUNT CHARACTERS
RET
PRAPER: TLNN F,PDQFLG ;PRINTING ESCAPE?
JRST PRAP2 ;NO
TCH ESC
TCH "."
RET
UPATM: STE 1,PNAM
JRST PRAT1
MOVEI 3,0(1)
HRLI 3,440700 ;MAKE INTO BYTE POINTER
ILDB 4,3 ;GET CHAR COUNT
JRST PRAT2
PRAT1: SBPC 3,1 ;STRING TO BYTE POINTER CONVERSION
PRAT2: MOVEM 3,UPATP
MOVEM 4,UPATC
RET
UPA: SOSGE UPATC ;COUNT CHARS
RET
ILDB 1,UPATP
JRST RSKP
U UPATP
U UPATC
;FLOATING POINT OUTPUT
A==3
B==4
C==5
W1==6
W2==7
PRFLT:
IFE TEN50,< MOVE 2,0(1)
MOVE 1,IOFNMP
MOVE 3,FLTFMC
TLNN F,PRXFLG ;USE STANDARD FORMAT
HRLZI 3,4000 ; WHEN FOR IPRE
FSC 2,0
FP4: FLOUT
JRST FP2 ;ERR RET, MAKE SURE BAD FORMAT
FP3: PUSH CP,1
JUMPL FX,FP5 ;REAL FILE
TRNN F,PMCFLG ;CHECKMARGIN
JRST FP5
HRRZ 5,CHPOS(FX)
JUMPE 5,FP5
SUB 1,IOFNMP ;COMPUTE NUMBER OF CHARS
HRRZ 3,1
IMULI 3,5
ROT 1,6
ANDI 1,77
IDIVI 1,7
SUBI 3,0(1)
ADDI 3,0(5)
CAMLE 3,LINSIZ ;CHECK MARGIN
TCH EOL
FP5: MOVE 5,IOFNMP
FP1: ILDB 1,5
CALL PREC
CAME 5,0(CP)
JRST FP1
POP CP,1
RET
FP2: CAME 1,IOFNMP ;BAD FORMAT?
JRST FP3 ;NO, JUST OVERFLOWED, GO ON
HRLZI 3,4000 ;USE STANDARD FORMAT
JRST FP4
U FLTFMC
; FLOATING FORMAT
FLTFMF: CAMN 1,KNIL
JRST FLTFM1
CAMN 1,KT
SKIPA 1,[XWD 4000,0]
CALL IUNBOX
EXCH 1,FLTFMC
JRST MKN
FLTFM1: MOVE 1,FLTFMC
JRST MKN
>
IFN TEN50,< MOVE 1,0(1)
MOVE A,1
JUMPG A,TFLOT1
JUMPE A,FP1A
MOVNS A
TCH "-"
TLZE A,400000
JRST FP1A
TFLOT1: MOVEI 2,↑D10
TLNN A,400
JRST APT ;IF UNNORMALIZED, TYPE AS DEC INTEGER??
FP1: MOVEI B,0
CAMGE A,FT01
JRST FP4
CAML A,FT8
AOJA B,FP4
FP1A: MOVEI C,0
FP3: MULI A,400
ASHC B,-243(A)
SETZM TEM1 ;INIT 8 DIGIT COUNTER
SKIPE A,B ;DONT TYPE A LEADING 0
PUSHJ CP,FP7 ;PRINT INTEGER PART OF 8 DIGITS
TCH "."
MOVNI A,10
ADD A,TEM1
MOVE W1,C
FP3A: MOVE 1,W1
MULI 1,12
MOVE W1,2
PUSHJ CP,FP7B
SKIPE ,W1
AOJL A,FP3A
POPJ CP,
FP4: MOVNI C,6
MOVEI W2,0
FP4A: ASH W2,1
XCT FPCP(B)
JRST FP4B
FMPR A,@FPCP+1(B)
IORI W2,1
FP4B: AOJN C,FP4A
PUSH CP,W2 ;SAVE EXPONENT
PUSH CP,B ;SAVE SIGN
PUSHJ CP,FP3 ;PRINT FFF.FFF PART OF NUMBER
TCH "E"
POP CP,1
JUMPG 1,.+2
TCH "-"
POP CP,A ;GET EXPONENT BACK
FP7: IDIVI A,12 ;DECIMAL OUTPUT SUBROUTINE
AOS TEM1
HRLM B,0(CP)
JUMPE A,FP7A1
PUSHJ CP,FP7
FP7A1: HLRZ 1,0(CP)
FP7B: ADDI 1,260
JRST @PREX ;TYPE CHAR
353473426555 ;1.0E32
266434157116 ;1.0E16
FT8: 233575360400 ;1.0E8
216470400000 ;1.0E4
207620000000 ;1.0E2
204500000000 ;1.0E1
FT: 201400000000 ;1.0E0
026637304365 ;1.0E-32
113715126246 ;1.0E-16
146527461671 ;1.0E-8
163643334273 ;1.0E-4
172507534122 ;1.0E-2
FT01: 175631463146 ;1.0E-1
FT0=FT01+1
FPCP: CAMLE A,FT0(C)
CAMGE A,FT(C)
Z FT0(C)
U TEM1
>
;PRINT STRING
PRSTR: CALL UPATM
JUMPL FX,PRSTR4 ;REAL FILE?
TRNN F,PMCFLG ;CHECK MARGIN?
JRST PRSTR4 ;NO
HRRZ 1,CHPOS(FX)
JUMPE 1,PRSTR4
ADDI 1,0(4)
CAMLE 1,LINSIZ ;EXCEED MARGIN?
TCH EOL ;YES - PRINT C.R.
PRSTR4: TLNE F,PDQFLG
TCH 42 ;PRINT DOUBLE QUOTE
JUMPLE 4,PRSTR1 ;ANY CHARS?
PRSTR2: ILDB 1,3
PRSTR5: TLNN F,PDQFLG ;PRINTING ESCAPES?
JRST PRSTR3 ;NO
CAIE 1,ESC ;CHAR IS " OR ESC ?
CAIN 1,42
TCH ESC ;YES - PRINT ESCAPE
PRSTR3: CALL PREC
SOJG 4,PRSTR2
PRSTR1: TLNE F,PDQFLG
TCH 42
RET
;PRINT ROUTINES NOT YET IMPLEMENTED
PRARR: JRST PRABAD ;ARRAY
;SYSOUT AND SYSIN
SYSOUT: SETZM ZORGJQ
CALL IOFN
MOVSI 1,400001
GTJFN
JRST [HRRZ 2,1(VP)
JRST OPNER3]
HRRZM 1,SYSJFN
MOVE 2,[XWD 440000,302000] ;36BIT, READ, WRITE, THAWED.
SKIPN KL20F ;READ REQUIRED ON TOPS 20
HRRI 2,102000 ;BUT IS SLOW ON TENEX
OPENF
JRST [MOVEI 2,0(1)
HRRZ 1,SYSJFN
RLJFN
JFCL
HRRZ 1,1(VP)
JRST OPNER6] ;CANNOT OPEN FILE ERROR
MOVE 1,[XWD 10,GCAC2] ;SAVE AC'S 10-17
BLT 1,GCAC2+7 ;FOR RETURN FROM SYSIN.
SYSOUE: MOVEM F,TFLGS
HRRZ 1,SYSJFN
MOVE 2,[POINT 36,[XWD 1000,1 ;WORD 0 (SEE JSYS MANUAL
0 ;SECT. 7 P 2. WORD1 DONE LATER.
XWD 1,140]] ;ENTRY VEC TO BOOT.
MOVNI 3,3 ;COUNT
SOUT
SKIPN ZORGJQ
SKIPA 2,[SIXBIT /SYSOUT/]
MOVE 2,[SIXBIT /MAKSYS/]
BOUT
MOVE 2,SYSDAT ;SYSDAT TO W4 OF FILE FOR SYSIN CHECK
BOUT
MOVE 2,[POINT 36,DADDYN]
MOVNI 3,↑D31 ;30 FOR DADDYNAME +1 FOR 1STFPN
SOUT
;Later we will emit main fork page 0 (which contains the bootstrap
;to unscramble all that comes later) and then go back and write the map
;word for GET to use over the zero at file word 1 above.
SKIPN ZORGJQ
SKIPA 3,[SYSBIT+PVTBIT]
SETZ 3,
CALL SYSMAP ;WRITE OUT MAP WORDS FOR THE WORLD.
HRRZ 1,SYSJFN
RFPTR
JSYS JSYSER
LSH 2,-LPS ;SKIP TO PAGE BOUND
ADD 2,[XWD 520000,1] ;PROT. FOR PMAP=520;+1 TO NXT PG.
HRRZI 3,1 ;NOW REPLACE 0 AT W1 WITH REGULAR GET
ROUT
HRRZI 2,(2)
HRRZI 3,↑D35 ;1STFPN WORD GIVES 1ST FILE PAGE NUM
ROUT ;DONE IN PAGE MODE.
HRRZI 6,(2) ;SAVE PBOUND
HRLI 1,400000 ;KEEP JFN BUT CLOSE TO MAKE SURE FILE
CLOSF
JSYS JSYSER ;REALLY THERE FOR UPCOMING INPUT GTJFN
MOVE 1,IOFNMP
HRRZ 2,SYSJFN
SETZ 3,
JFNS
MOVE 2,IOFNMP ;NAME (JFNS OUTPUT) FOR GETTING INPUT JFN
HRLZI 1,100001 ;OLD FILE NOW.
GTJFN
JSYS JSYSER
HRLM 1,SYSJFN ;LH=READ JFN; RH=WRITE JFN NOW
MOVE 2,[XWD 440000,302000] ;36 BIT READ THAWED
OPENF
JSYS JSYSER
HRRZI 2,↑D36 ;SKIP TO 1ST MAPWORD
SFPTR
JSYS JSYSER
HRRZ 1,SYSJFN
MOVE 2,[XWD 440000,302000] ;AS BEFORE
SKIPN KL20F
HRRI 2,102000 ;WRITE ONLY ON TENEX
OPENF
JSYS JSYSER
HRRZI 2,(6)
LSH 2,LPS
SFPTR ;READY TO WRITE PAGES AT END.
JSYS JSYSER
SYSPLP: HLRZ 1,SYSJFN
BIN ;READ 1 MAP WORD.
JUMPE 2,SYSDON
HRRZ 1,SYSJFN ;OUTPUT JFN AGAIN
TRNE 2,7000 ;0 HERE SEZ MAIN FORK
JRST SYSHPG
HLRZ 3,2
LSH 3,LPS
MOVNS 3
LSH 2,LPS
HRLI 2,444400
SOUT
JRST SYSPLP
SYSHPG: HLRZ 6,2 ;PAGE CNT
HRRZI 5,(2)
ANDI 5,777 ;FORK PAGE NUM
LSH 2,-LPS
ANDI 2,7 ;FORK NUMBER,+1
SOSGE 2
0
HRL 5,SWFRKS(2) ;FORK HANDLE
HPGLP: MOVE 1,5
MOVE 2,[XWD 400000,777]
HRLZI 3,100000
PMAP
HRRZ 1,SYSJFN
MOVNI 3,1000
MOVE 2,[POINT 36,777000]
SOUT
AOS 5
SOJG 6,HPGLP
JRST SYSPLP
SYSDON: SKIPE ZORGJQ
JRST SYSDN1
HRRZ 1,SYSJFN
CALL FILNM
PUSH PP,1
HLRZ 1,SYSJFN
CLOSF ;CLOSE READING JFN FIRST SO THAT EOF RESET RIGHT
JFCL
HRRZ 1,SYSJFN
CLOSF
JFCL
POP PP,1
RET
SYSDN1: HLRZ 1,SYSJFN
CLOSF ;CLOSE JFN FOR READING & RELEASE
JFCL
HRRZ 1,SYSJFN
HRLI 1,400000
CLOSF ;CLOSE WRITING ONE, DON'T RELEASE. IT'S CLOSED
JFCL ;SECOND TO GET EOF RESET TO END.
HRRZ 6,SYSJFN ;PARAM FOR MBOOT.
JRST MBOOT
;"Return" from MAKESYS or SYSOUT when it's run.
SYSINR: HRRZI 1,400000
MOVE 2,[XWD EVSIZE,EVEC]
SEVEC
HRRZ 1,MYJFNS
JUMPE 1,MKSYSA ;MAKESYS
MOVE 1,[XWD MYFRKS+1,SWFRKS] ;CROCK: 1ST FORK IN MYFRKS
;ACTUALLY MAINFORK (400000)
HRRZI 2,SWFRKS-1
BLT 1,NSWFRKS(2)
MOVE 1,[XWD GCAC2,10]
BLT 1,17
MOVE F,TFLGS
SETK20 ;SET TOPS 20 FLG
SETZM FR ;SET CURRENT FILES TO TTY
SETZM DRIBFX ;TURN OFF ANY DRIBBLING
MOVEI 1,1
MOVEM 1,FP
MOVSI 3,-NFILES+2 ;CLEAR FILE TABLE
SETZM FILEA+2(3)
AOBJN 3,.-1
TIME
MOVEM 1,LOGTOD
GETJRT
MOVEM 1,LOGRT
SETZM GCRT
CALL SETTRP ;MAGIC PP OVERFLOW PAGE-INIT PROTECTION
CALL RESTCB ;Restore swapping buffer.
; JSYS BRREST ;I have taken this out N times now.
;I keep putting it back, but it is
;unnecessary & wrong, given RESTCB.
CALL SETINT
CALL SETMOD
IFDEF MAXC,<
CALL DSFBLP
>
HLRZ 1,MYJFNS
CALL FILNM
PUSH PP,1
HRRZ 1,MYJFNS
JUMPN 1,.+2
SKIPA 1,KNIL
CALL FILNM
POP PP,2
JRST CONS
SYSMAP: SETZB 1,ZPAGE ;ITERATE THRU PP 0 TO ENDCOR ON ZPAGE
SETZM LPAGE ;COUNT # PP IN A ROW TO BE SAVED
SYMP1: CAIG 1,776 ; LAST PAGE?
SKIPN 2,TYPTAB(1)
JRST SYMPDN
JUMPE 3,SYMPS ;0=> MAKESYS - SAVE ALL
TLNE 2,PVTBIT
JRST SYMPS ;SAVE IF PVTBIT=1
TLNE 2,SYSBIT
JRST SYMPNX ;DONT SAVE IF SYSBIT=1
SYMPS: MOVEI 2,0(2)
CAIE 2,BTABT ;NEVER SAVE BITTABLE PAGES
CAMN 1,PPTRP ;DON'T SAVE PDLOV TRAP PAGE
JRST SYMPNX
SKIPN CBSIZE ;IF THERE'S A SWAPPING BUFFER,
JRST SYMP2
CAMG 1,CBRANG+1 ;DON'T SAVE SWAPPING BUFFER
CAMGE 1,CBRANG
SKIPA 2,CBTHED ;OR CORE BUFFER TABLE PAGE
JRST SYMPNX
CAIN 1,(2)
JRST SYMPNX
SYMP2: HRLI 1,400000
RPACS
TLNE 2,10000 ;PAGE MUST EXIST TOO
AOSA LPAGE ;COUNT 1 GOOD PAGE TO EMIT.
SYMPNX: CALL SMEMIT ;EMIT 'EM WHEN FIND 1ST BAD 1
AOS 1,ZPAGE ;READY TO CHECK NEXT PAGE
JRST SYMP1
SMEMIT: SKIPN 1,LPAGE ;COUNT PP THIS BLOCK
RET ;NONE
HRRZ 2,ZPAGE
SUBI 2,(1) ;RH=1ST PAGE IN GROUP
HRLI 2,(1) ;LH=COUNT
HRRZ 1,SYSJFN
BOUT
SETZM LPAGE
RET
SYMPDN: CALL SMEMIT ;MAKE SURE BLOCK CLOSED OUT
AOS 1,ZPAGE ;COUNT TO NEXT IN CASE REALLY
HRRZI 2,(1) ;NOT DONE
CAIG 2,776 ;CHECK AGAINST MAX. ALLOWABLE PAGE NUMB.
JRST SYMP1
;NOW FOR SHADOW
SETZM LPAGE
SETZB 1,ZPAGE
SMSHLP: CALL GFRKB
CAIN 2,FSYSBT ;SAVE IF PVTBIT 1 OR SYSBIT 0
JUMPN 3,SMSHNX ;OR IF A MAKESYS
HLRZ 2,1
LSH 1,-LPS
ANDI 1,777
HRL 1,SWFRKS(2)
SKIPN SWFRKS(2) ;NOTHING HAS EVER BEEN SWAPPED
JRST SMSHNX ;I ASSUME. IF SO WON'T LOOK FAR.
RPACS
MOVE 1,ZPAGE
TLNE 2,10000
AOSA LPAGE
SMSHNX: CALL SHEMIT
HRRZI 1,1000
ADDB 1,ZPAGE
CAMLE 1,HISHAD
JRST SMSHDN
TRNN 1,777000 ;IF NEXT PAGE 1ST IN ITS FORK
CALL SHEMIT ;FORCE,
JRST SMSHLP
SHEMIT: SKIPN 2,LPAGE
RET
SETZM LPAGE
LSH 1,-LPS
SUBI 1,(2)
ANDI 1,777
HRLI 1,(2) ;1 = COUNT,FORKPAGE
MOVE 2,ZPAGE
SUBI 2,1000 ;ONLY MATTERS IF FORKBOUND FORCED EMIT.
LSH 2,-LPS
ANDI 2,17000 ;GOT THE FORK BITS, BUT MUST OFFSET
ADDI 2,1000 ;BY 1 FOR SYSOUT TO DISTINGUISH MAINFRK
IOR 2,1
HRRZ 1,SYSJFN
BOUT
MOVE 1,ZPAGE
RET
SMSHDN: CALL SHEMIT
HRRZ 1,SYSJFN
SETZ 2,
BOUT ;TERMINAL 0
RET
SYSIN: CALL IOFN
MOVSI 1,(1B2+1B17)
GTJFN
JRST [HRRZ 2,1(VP)
JRST OPNER3]
HRRZI 6,(1)
HRLZI 1,100001
HRROI 2,[ASCIZ /<LISP>BOOT.SAV/]
GTJFN
JRST [HRROI 1,[ASCIZ /NO BOOTSTRAP/]
PSOUT
JRST FALSE]
HRLI 1,400000
GET
HRRZI 1,(6)
CALL 777000 ;GO TO THE BOOTSTRAP
MOVE 1,1(VP)
ERROR1 30,RESET
U SYSFIL
U SYSJFN
U ZPAGE
U LPAGE
U ZORGJQ ;FLAG DURING SYSOUT/MAKESYS SEZ WHICH
;IS HAPPENING
MYJFN: HLRZ 1,MYJFNS
JUMPE 1,.+2
AOS (CP)
RET
;SYSTEM TYPE - RETURN EITHER TOPS20 OR TENEX
SYSTYP: HRRZ 1,KTENEX
SKIPE KL20F
HRRZ 1,KTOP20
RET
CLRBUF: IFN TEN50,<
UCLRBF: CLRTIB ;CLEAR TTY IN BUF
>
IFE TEN50,<MOVEI FX,0
JRST CLRBF1
UCLRBF: CALL IFSET
HRRZ 2,2(VP)
CAME 2,KNIL
JUMPE FX,CLRBFS ;SECOND ARG NOT NIL AND FILE TTY
CLRBF1: HRRZ 1,FILEN(FX)
CFIBF
JUMPN FX,CLRBF9
>
CLRBF3: CALL CLRTTY
CLRBF9: HRRZ 1,KNIL
RET ;DONT DO JRST FALSE CAUSE OF GC OUTMAP
JRST FALSE
IFE TEN50,<
CLRBFS: MOVEI FX,0 ;SAVE STUFF IN TTY BUFFERS
HRRZ 1,FILEN(FX)
SKIPG LNBFC
SIBE
JRST .+3
HRRE 1,FCHAR(FX)
JUMPL 1,CLRBF3 ;NOTHING TO SAVE - DONT CHANGE VALUES
MOVE 1,SYSBFP
MOVEM 1,CSYSBP
MOVEI 1,CLRBFC
CALL CLRBSS
MOVE 1,SLNBFP
MOVEM 1,CSLNBP
HRRE 1,FCHAR(FX)
SKIPL 1
CLRBF6: IDPB 1,CSLNBP
SOSGE LNBFC
JRST CLRBF3
ILDB 1,LNBFP
JRST CLRBF6
CLRBFC: IDPB 1,CSYSBP
RET
CLRBSS: MOVEM 1,CLRBFI ;ROUTINE TO CALL FOR EACH CHAR
HRRZ 1,FILEN(FX)
RFMOD
MOVEM 2,OLDMOD
TRZ 2,6000 ;SET TO NO ECHO
TRO 2,1B23 ;AND WAKEUP ON EVERYTHING
SFMOD
HRRZ 1,FILEN(FX)
SIBE
JRST CLRBF2
CLRBFO: MOVE 2,OLDMOD
SFMOD
RET
CLRBF2: MOVEM 2,CLRBFN
CLRBF4: HRRZ 1,FILEN(FX)
SOSGE CLRBFN
JRST CLRBFO
BIN
MOVEI 1,0(2)
CALL @ CLRBFI
JRST CLRBF4
U CLRBFN
U CLRBFI
U OLDMOD
SYSBFP: POINT 7,SYSBF,-1
U CSYSBP
U SYSBF,↑D32 ;BUFFER FOR SAVED SYSTEM BUFFER
SLNBFP: POINT 7,SLNBF,-1
U CSLNBP
;MAKE STRING OUT OF SAVED SYSTEM AND LINE BUFFERS
LINBUF: MOVE 6,CSLNBP
MOVE 7,SLNBFP
CAMN 1,KNIL
JRST LINBF1 ;ARG NIL MEANS CLEAR SAVED BUFFER
LINBF3: CAMN 6,7
JRST FALSE
CALL MKSTRS
LINBF2: ILDB 1,7
CALL MKSTR1
CAME 6,7
JRST LINBF2
MOVE 1,UNP1
JRST MKSP
LINBF1: MOVEM 7,CSLNBP
RET
SYSBUF: MOVE 6,CSYSBP
MOVE 7,SYSBFP
CAME 1,KNIL
JRST LINBF3
MOVEM 7,CSYSBP
RET
> ;END OF IFE TEN50
;SETUP FOR INPUT FUNCTION
IFSET: MOVEI FX,FIN ;CHARACTER INPUT ROUTINE
MOVEM FX,RDAX ;INPUT DISPATCH
CAMN 1,KNIL ;STANDARD FILE?
JRST IFS3 ;YES
LDT 5,1
CAIN 5,STPTT ;IS IT A STRING?
JRST IFS6 ;YES
CALL IFSCH ;SEARCH TABLE FOR INPUT FILE
JRST ILLIF ;FAILS
IFS5: MOVEI FX,0(3)
IFS2: MOVEM FX,FRX
CAIE FX,NFILES ;INPUT FROM STRING?
RET ;NO
MOVEI 5,STRIN ;YES - SET RDAX
MOVEM 5,RDAX
RET
IFS6: MOVEI FX,NFILES ;FILE NUMBER FOR STRING INPUT
HRRZ 5,FILEA(FX)
CAIN 1,(5) ;SAME STRING AS BEFORE?
JRST IFS2
HRRE 4,FCHAR(FX) ;NO - SET THINGS UP
SKIPL 4
SOS 0(5) ;BACK UP THE STRING
HLLOS FCHAR(FX)
HRRZM 1,FILEA(FX)
JRST IFS2
IFS3: MOVE FX,FR ;USE STANDARD INDEX
JRST IFS2
;SEARCH OPEN FILE TABLE FOR NAME OF INPUT FILE
IOFSCH: MOVEI 5,600000 ;SEARCH FOR I/O FILE
SKIPA
IFSCH: MOVEI 5,400000 ;SEARCH FOR INPUT (ONLY) FILE
PUSH PP,2 ;READ AND FRIENDS HAVE READTBL HERE
PUSH PP,1
IFSC3: MOVSI 3,-NFILES
IFSC1: HLRZ 4,FCHAR(3)
ANDI 4,0(5)
CAIE 4,0(5) ;RIGHT TYPE?
JRST IFSC2 ;NO, IGNORE
HRRZ 4,FILEA(3) ;GET NAME
CAIN 4,0(1)
JRST IFSCG ;FOUND, RETURN SKIPPING
IFSC2: AOBJN 3,IFSC1
IFE TEN50,<
TLON 5,1
CALL IFREC ;TRY AGAIN WITH RECOGNIZED NAME
JRST IFSCB ;ILLEGAL NAME OR NO JFNS AVAIL
JRST IFSC3
>
IFSCB: POP PP,1 ;NOT FOUND RETURN NO-SKIP, ORIG ARG
POP PP,2
RET
IFSCG: SUB PP,BHC+1 ;FOUND - RETURN FULL NAME
POP PP,2
JRST RSKP ;AND SKIP
;SETUP FOR OUTPUT FUNCTION
OFSET: MOVEI FX,FOUT ;CHARACTER OUTPUT ROUTINE
MOVEM FX,PREX ;OUTPUT DISPATCH
CAMN 2,KNIL ;STANDARD FILE?
JRST OFS3 ;YES
CALL OFSCH ;SEARCH TABLE FOR NAME
JRST OFS4 ;NOT FOUND
OFS5: MOVEI FX,0(3) ;INDEX
OFS2: MOVEM FX,FPX
RET
OFS4: PUSH PP,1 ;TRY IO FILE
MOVEI 1,0(2)
CALL IOFSCH
JRST ILLIF ;NO FOUND - GIVE UP
MOVEI 2,0(1)
POP PP,1
JRST OFS5
OFS3: MOVE FX,FP ;USE STANDARD FILE
JRST OFS2
;SEARCH OPEN FILE TABLE FOR NAME OF OUTPUT FILE
OFSCH: TRZ 5,1 ;SEARCH FOR OUPUT FILE
PUSH PP,2
OFSC3: MOVSI 3,-NFILES
OFSC1: HLRZ 4,FCHAR(3)
ANDI 4,200000
CAIE 4,200000
JRST OFSC2
HRRZ 4,FILEA(3) ;GET NAME
CAIN 4,0(2)
JRST OFSCG ;FOUND, RETURN SKIPPING
OFSC2: AOBJN 3,OFSC1
IFE TEN50,<
TRON 5,1
CALL OFREC ;NOT FOUND - TRY FULL NAME
JRST OFSCB ;ILLEGAL NAME OR NOT FOUND
JRST OFSC3
>
OFSCG: SUB PP,BHC+1 ;FOUND, RETURN SKIP W. FULL NAME
JRST RSKP
OFSCB: POP PP,2 ;NOT FOUND - RETURN ORIG. NAME
RET
ILLOF: MOVEI 1,0(2)
ILLIF: ERROR1 15,RESET
FSCH: MOVSI 3,-NFILES ;SEARCH FOR INPUT OR OUTPUT FILE
FSC1: HRRZ 4,FILEA(3)
CAIN 4,0(1)
JRST RSKP
AOBJN 3,FSC1
CALL IFSCH
SKIPA
JRST RSKP
MOVEI 2,0(1)
CALL OFSCH
RET
MOVEI 1,0(2)
JRST RSKP
;GIVEN JFN IN 1, GET FULL NAME OF FILE
IFE TEN50,<
FILNM: MOVEI 2,0(1) ;JFN
MOVE 1,IOFNMP
MOVSI 3,(2B2+1B5+1B8+1B11+1B14)
HRRI 3,1
JFNS ;GET STRING
CALL PACS ;SETUP TO MAKE ATOM
MOVE 3,1
MOVE 4,IOFNMP
FILNM1: CAMN 3,4
JRST MKATM ;MAKE ATOM
ILDB 1,4
CALL PAC
JRST FILNM1
;GET FULL NAME OF INPUT FILE
IFREC: CALL IOFN
MOVSI 1,(1B2+1B17) ;OLD FILE - SHORT FORM
IFREC1: GTJFN
JRST FALSE ;BAD NAME OR NO JFNS
PUSH PP,1 ;SAVE JFN
PUSHN 5
CALL FILNM ;GET FILE NAME
POPN 5
EXCH 1,0(PP)
RLJFN ;RELEASE JFN
JFCL
POP PP,1 ;NAME
JRST RSKP
;GGET FULL NAME OF OUTPUT FILE
OFREC: PUSH PP,1
MOVEI 1,0(2)
CAMN 1,KLPT ;LPT IS A CROCK
JRST OFREC3
CALL IOFN
MOVSI 1,(1B0+1B17) ;FOR WRITING - SHORT FORM
CALL IFREC1
SKIPA
OFREC3: AOS 0(CP)
MOVEI 2,0(1)
POP PP,1
RET
>
;GET FOLL NAME OF FILE FOR INPUT
INFILP: IFE TEN50,<
CALL IFREC
JRST FALSE
RET
>
IFN TEN50,<
CALL IFSCH
JRST FALSE
RET
>
;GET FULL NAME OF FILE FOR OUTPUT
OUFILP: MOVEI 2,0(1)
IFE TEN50,< CALL OFREC
>
IFN TEN50,< CALL OFSCH
>
JRST FALSE
MOVEI 1,0(2)
RET
;OPEN FILE FOR INPUT
INFILE: STN 1,STPT ;STRING?
JRST SETINF ;YES, JUST DO AN INPUT
CALL IFSCH ;FILE ALREADY OPEN?
CAMN 1,KNIL ;OR NO NAME GIVEN?
JRST SETINF ;THEN SET STANDARD FILE ONLY
PUSH PP,1 ;SAVE NAME
CALL IOFN ;SETUP NAME STRING FROM ATOM
MOVEI 4,0 ;USE MODE 0
CALL INFIL ;OPEN FILE
CALL IOGB ;ASSIGN SLOT IN FILE TABLE
MOVSI 1,400000
HLLOM 1,FCHAR(2) ;INPUT FILE HAS BIT 0=1
MOVEI FX,0(2)
JRST INPUT2
;SET STANDARD INPUT FILE
SETINF: MOVE FX,FR
CAMN 1,KNIL ;IF NO NAME GIVEN,
JRST INPUT1 ;RETURN NAME OF CURRENT STANDARD FILE
CALL IFSET ;LOOKUP NAME
INPUT2: EXCH FX,FR ;STANDARD FILE INDEX
INPUT1: HRRZ 1,FILEA(FX) ;GET FILE NAME
RET
;OPEN FILE FOR OUTPUT
OUFILE: MOVEI 2,0(1)
CALL OFSCH ;FILE ALREADY OPEN?
CAMN 1,KNIL ;OR NO NAME GIVEN?
JRST SETOUF ;THEN SET STANDARD FILE ONLY
PUSH PP,1
CALL IOFN ;SETUP NAMD STRING FROM ATOM
MOVEI 4,0 ;MODE 0
CALL OUTFIL ;OPEN FILE
CALL IOGB ;ASSIGN SLOT IN FILE TABLE
MOVSI 1,200000 ;SET BIT 1 IN FCHAR FOR OUTPUT FILE
HLLOM 1,FCHAR(2)
MOVEI FX,0(2)
JRST OUTPU2
;SET STANDARD OUTPUT FILE
SETOUF: MOVE FX,FP
CAMN 1,KNIL ;IF NO NAME GIVEN
JRST OUTPU1 ;RETURN NAME OF CURRENT STANDARD FILE
MOVEI 2,0(1)
CALL OFSET ;LOOKUP NAME
OUTPU2: EXCH FX,FP ;STANDARD FILE INDEX
OUTPU1: HRRZ 1,FILEA(FX) ;GET NAME
RET
;CLOSE FILE
CLOSLF: CAMN 1,KNIL
JRST CLOS2 ;NO NAME GIVEN, TRY STANDARD FILE
CALL FSCH ;INPUT OR OUTPUT FILE?
JRST ILLIF ;NO, ERROR
CLOS3: HRRZ 1,FILEA(3)
PUSH PP,1 ;SAVE NAME FOR VALUE
MOVEI 2,0(3) ;CHECK FOR ONE OF TWO STANDARD FILES
CAMN 2,FR ;INPUT?
SETZM FR ;YES, RESET TO TTY
MOVEI 1,1
CAMN 2,FP ;OUTPUT?
MOVEM 1,FP ;YES, RESET TO TTY
CAIG 2,1
JRST CLOS4 ;DON'T CLOSE TTY
CAMN 2,DRIBFX ;DONT CLOSE DRIBBLE FILE
JRST CLOS4
SETZM FILEA(2)
HRRZ 1,FILEN(2) ;FILE NUMBER
CALL CLOSEF ;SYSTEM CLOSE FILE
POP PP,1 ;RETURN NAME OF FILE CLOSED
RET
CLOS4: POP PP,1 ;DON'T CLOSE THE FILE
JRST FALSE ;RETURN NIL SO THE USER KNOWS
CLOS2: SKIPE 3,FR ;STND INPUT FILE NOT TTY?
JRST CLOS3 ;YES, CLOSE IT
MOVE 3,FP
CAIE 3,1 ;STND OUTPUT FILE NOT TTY?
JRST CLOS3 ;YES, CLOSE IT
JRST FALSE ;NO FILE TO CLOSE
CLSALL: MOVSI 3,-NFILES ;CLOSE ALL FILES
SKIPE FILEA(3)
CALL CLOS3
AOBJN 3,.-2
JRST FALSE
UCLSAL: CALL OPNLST ;USER CLOSEALL
PUSH PP,1
CALL CLSALL
POP PP,1
RET
OPNLST: HRRZ 1,KNIL
MOVSI 5,-NFILES+2
OPNLS2: SKIPN 2,FILEA+2(5)
JRST OPNLS1
HRRZI 4,2(5)
CAMN 4,DRIBFX ;DONT SHOW DRIBBLE FILE
JRST OPNLS1
EXCH 1,2
CALL CONS
OPNLS1: AOBJN 5,OPNLS2
RET
;OPEN FILE FOR INPUT AND OUTPUT
IFE TEN50,<
IOFILE: CALL IOFSCH
JRST IOFIL1 ;ALREADY THERE
MOVEI FX,0(3)
JRST INPUT1
IOFIL1: PUSH PP,1
CALL IOFN
MOVEI 4,0
CALL IOFIL
CALL IOGB
MOVSI 1,600000
HLLOM 1,FCHAR(2)
MOVEI FX,0(2)
JRST INPUT1
;OPEN FILE - BITS GIVEN - OPTIONAL THIRD ARG IS GTJFN BITS
OPENF: PUSH PP,1
MOVEI 1,0(2)
CALL IUNBOX ;BITS
PUSHN 1
HRRZ 1,0(PP)
STE 1,ATOM ;FILE NAME?
JRST OPEN1 ;NO ASSUME JFN
CALL IOFN
PUSH CP,2
HRRZ 1,3(VP)
CAMN 1,KNIL
JRST OPEN2
CALL IUNBOX
JRST OPEN3
OPEN2: MOVSI 1,(1B2+1B17) ;OLD FILE
MOVE 3,-1(CP)
TRNN 3,220000 ;READ OR APPEND?
MOVSI 1,(1B0+1B17) ;NO - GET FOR WRITING
OPEN3: POP CP,2
GTJFN
JRST OPNER1 ;BAD NAME OR NO JFNS
SKIPA
OPEN1: CALL IUNBOX
MOVE 2,0(CP)
MOVEI 4,0(1)
OPENF
JRST OPNB ;WONT OPEN
CALL IOGB
POPN 1
TRNE 1,020000 ;IF APPEND
TRO 1,100000 ;...SET WRITE
LSH 1,1
ANDI 1,600000
HRLOM 1,FCHAR(2) ;SAVE READ&WRITE BITS
HRRZ 1,FILEA(2) ;FULL NAME
RET
;GET JFN OF OPEN FILE
OPNJFN: CAME 1,KNIL
CALL OPENP
CAMN 1,KNIL
JRST OPNJX
HRRZ 1,FILEN(3)
JRST MKN
OPNJX: HRRZ 1,1(VP)
JRST ILLIF
> ;END OF IFE TEN50
; SUPERDRIBBLEP()
SPDRBP: MOVE 1,KNIL
SKIPE DRIBVB
MOVE 1,KT
RET
; SET VERBOSE DRIBBLE (SUPERDRIBBLE FLG)
SPRDRB: SETZ 2,
CAME 1,KNIL
SETO 2,
EXCH 2,DRIBVB
MOVE 1,KNIL
SKIPE 2
MOVE 1,KT
RET
; SET THE DRIBBLE FILE
SETDRB: CAMN 1,KNIL ;NIL?
JRST SETDB2 ;YES, TURN OFF DRIBBLING
MOVE 2,1
CALL OFSET ;FIND THE FILE
CAIN FX,1 ;TTY?
SETDB2: SETZ FX, ;YES, EQUIV TO NIL
EXCH FX,DRIBFX
DRIBP2: JUMPE FX,FALSE ;WAS NONE BEFORE
HRRZ 1,FILEA(FX) ;GET PREVIOUS FILE
JUMPE 1,FALSE
RET
; GET THE CURRENT DRIBBLE FILE
DRIBP: MOVE FX,DRIBFX
JRST DRIBP2
;I-O LOCAL SUBR'S
;SETUP FILE NAME STRING FROM ATOM
;ASSIGN SLOT IN OPEN FILE TABLE - JFN IN 1, NAME ON PP
IOGB: MOVSI 2,-NFILES
SKIPN FILEA(2) ;AVAILABLE ENTRY?
JRST IOGB1 ;YES
AOBJN 2,.-2 ;NO
ERROR0 17,RESET ;TOO MANY FILES OPEN
IOGB1: MOVEM 1,FILEN(2) ;FILE NUMBER
SETZM CHPOS(2) ;CLEAR STATE WORDS
EXCH 2,0(PP)
CAMN 2,KLPT ;YEECH - LPT CROCK
SKIPA 1,2
CALL FILNM ;GET FULL FILE NAME
POP PP,2
MOVEM 1,FILEA(2)
RET
IOFN: STN 1,ATOM
JRST ARGNA+1
STE 1,STRNG
ARGNA: ERROR1 16,RESET
HLRZ 1,2(1)
CALL UPATM
MOVE 7,IOFNMP
IOFN1: CALL UPA ;SETUP STRING FOR GTJFN FROM ATOM
JRST IOFN2 ;ATOM FINISHED
IDPB 1,7
JRST IOFN1
IOFN2: SETZ 1,
IDPB 1,7 ;NULL MARKS END OF STRING
MOVE 2,IOFNMP
RET
IOFNMP: XWD 010700,IOFNM-1
U IOFNM,26
IOFIL: MOVEI 3,1B19+1B20 ;READ AND WRITE BITS
SKIPA
INFIL: MOVEI 3,1B19 ;READ BIT FOR OPENF
MOVSI 1,(1B2+1B17) ;OLD FILE BIT+SHORT FORM BIT
OPNFIL: GTJFN
JRST OPNER1 ;ERROR
HRRZS 4,1 ;CLEAR LH
MOVEI 2,0(3) ;GET OPENF FLAGS
HRLI 2,(7B5) ;ASCII CHARACTER SIZE
OPENF
JRST OPNB
RET
OPNB: MOVEI 2,0(1)
CAIN 1,OPNX1 ;ALREADY OPEN?
JRST OPNER2 ;YES
MOVEI 1,0(4) ;NO - RELEASE JFN
RLJFN
JFCL
OPNER2: POP PP,1
OPNER6: CAIL 2,OPNX3
CAILE 2,OPNX6
JRST OPNER5
ERROR1 51,RESET ;PROTECTION VIOLATION
OPNER5: CAIE 2,OPNX13
CAIN 2,OPNX15
ERROR1 51,RESET ;PROTECTION VIOLATION
CAIN 2,601132 ;=OPNX23 ON TOPS 20
ERROR1 26,RESET ;DISK QUOTA EXCEEDED
CAIE 2,OPNX10
CAIN 2,OPNX17
ERROR1 26,RESET ;RESOURCES EXCEEDED (DIR FULL,ETC)
ERROR1 11,RESET
OPNER1: POP PP,2 ;GTJFN ERRORS
OPNER3: EXCH 1,2
CAIN 2,GJFX23
ERROR1 26,RESET ;DIRECTORY FULL
CAIG 2,GJFX2
ERROR1 27,RESET ;CALL ILL. JFN FILE NOT FOUND?
CAIE 2,GJFX3
CAIN 2,GJFX22
ERROR1 26,RESET ;NOT ENUF SYS. RESOURCES (JFN'S OR JSB)
CAIN 2,GJFX35 ;DIR. ACCESS PRIV. REQUIRED
ERROR1 51,RESET
CAIL 2,GJFX16
CAILE 2,GJFX21
JRST OPNER4
ERROR1 27,RESET ;FILE NOT FOUND (NO SUCH DIR, EXT, ETC)
OPNER4: CAIE 2,GJFX27
CAIN 2,GJFX24
ERROR1 27,RESET
ERROR1 52,RESET ;REST ARE GARBAGE FILE NAME????
OUTFIL: MOVSI 1,(1B0+1B17) ;FOR WRITING BIT+SHORT FORM BIT
MOVEI 3,1B20
JRST OPNFIL
CLOSEF: CLOSF
JFCL
RET
;NUMBER PRINTERS
PNO8: PUSH CP,2
MOVEI 2,10 ;OCTAL TO TTY
JRST PNO101
PNO10: PUSH CP,2
MOVEI 2,↑D10 ;DECIMAL TO TTY
PNO101: PUSH CP,3
PUSH CP,4
PUSH CP,FX
PUSH CP,PREX
MOVEI FX,0
MOVEI 3,TCO
MOVEM 3,PREX
CALL APT
POP CP,PREX
POP CP,FX
POP CP,4
POP CP,3
POP CP,2
RET
APT: MOVEI 3,0 ;CHAR COUNT
MOVEI 4,0 ;PREFIX
TRO F,PMCFLG ;ENABLE MARGIN CHECKING
APTX: MOVEM 2,APTR ;ANY RADIX OUT VIA PREC
APT1: LSHC 1,-↑D35
LSH 2,-1
DIV 1,APTR
HRLM 2,0(CP)
ADDI 3,1
JUMPE 1,APT4
PUSHJ CP,APT1
APT2: HLRZ 1,0(CP)
ADDI 1,60
PREC: JRST @PREX ;TCO, FOUT OR INTERNAL SUBR
APT4: JUMPL FX,APT5 ;REAL FILE
TRNN F,PMCFLG ;CHECK MARGIN?
JRST APT5 ;NO
HRRZ 1,CHPOS(FX)
ADDI 1,0(3)
CAMLE 1,LINSIZ
TCH EOL
APT5: JUMPE 4,APT2
TCH 0(4)
JRST APT2
;THIS USED TO COUNT LINES BUT NOBODY USED IT SO REMOVE
CHACCT: CAIGE 1,40 ;COUNT CHARS
JRST PRECC
PREC1: AOS CHPOS(FX)
RET
PRECC: CAIE 1,EOL
CAIN 1,15
JRST PRECR
CAIN 1,12
RET ;LINE FEED DOESNT CHANGE POSITION
AOS CHPOS(FX)
JRST PREC1
PRECR: HLLOS CHPOS(FX)
JRST PREC1
;OUTPUT CHARACTER TO FILE
FOUT: CALL CHACCT ;ACCOUNT CHARACTER
PUSH CP,2
HRRZ 2,FILEN(FX) ;FILE NUMBER
FOUT4: EXCH 1,2
CAIN 2,EOL
JRST FOUT1
BOUT
FOUT2: EXCH 1,2
CAIN 2,101 ;OUTPUTING TO TTY?
SKIPN 2,DRIBFX ;... AND DRIBBLING?
JRST FOUT5 ;NO
FOUT6: HRRZ 2,FILEN(2) ;YES, DO THE DIRBBLING
JRST FOUT4
FOUT5: POP CP,2
RET
;INPUT CHARACTER FROM FILE
FIN: JUMPE FX,GCHIT ;TTY (LINE BUFFERED) INPUT
FIN1: PUSH CP,2
HRRZ 1,FILEN(FX) ;GET JFN
BIN
JUMPE 2,FIN2 ;PROBABLY EOF
FIN8: CAIE 2,15 ;CR?
JRST FIN4 ;NO
BIN ;FLUSH FOLLOWING LF
CAIE 2,12 ;MAKE SURE IT IS A LF
JRST FIN5
MOVEI 2,EOL ;USE EOL
FIN4: MOVE 1,2
JUMPN FX,FIN6 ;GO ACCOUNT CHARACTER
MOVEI FX,1 ;IF TTY IN,
HRRZ 2,TTYTBL ;CHECK ECHO
SKIPN INCTLA ;ECHO'S OFF DURING ↑A
SKIPN ECHMDW(2)
JRST FIN7 ;OFF
SKIPE 2,DRIBFX ;VERBOSE DRIBBLE CHECK
SKIPN DRIBVB ;
JRST FIN6 ;
PUSH CP,[FIN6] ;
PUSH CP,2 ;
JRST FOUT6 ;DRIBBLE THE CHAR
FIN6: MOVE 2,0(CP)
CALL CHACCT ;ACCOUNT AS FOR TTY OUT
FIN7: POP CP,2
MOVE FX,FRX
RET
FIN5: BKJFN ;CR WTH NO LF, BACKUP ONE CHAR
JFCL ;(WHO CAN IT FAIL?)
MOVEI 2,15 ;RETURN CR
JRST FIN4
FOUT1: CAIE FX,1
AOS EOLCNT
MOVEI 2,15 ;CONVERT TO CR,LF
BOUT
MOVEI 2,12
BOUT
MOVEI 2,EOL
JRST FOUT2
FIN2: GTSTS
TLNN 2,1B26 ;EOF?
SKIPA 2,[0] ;NOT EOF
SKIPA ;EOF YES
JRST FIN4 ;EOF NO
PUSHN FX
HRRZ 1,FILEA(FX)
ERROR1 20,FIN9
FIN9: POPN FX
CALL IUNBOX
MOVEI 2,0(1)
ANDI 2,177
JRST FIN8
;READ A CHAR FROM A STRING
; THE STRING POINTER IS KEPT IN BOXED FORM ONLY SO THAT
; WE ARE OK IF A GC OCCURS AND THE STRING MOVES
STRIN: HRRZ 7,FILEA(FX) ;GET THE STRING
MOVE 3,(7)
USBPC 1,3
SOJL 2,STREOF ;EMPY STRING
ADD 3,[-7777777] ;LENGTH-1 & CHAR POS + 1
MOVEM 3,0(7) ;RESTORE STRING POINTER
ILDB 1,1 ;GET THE CHAR OUT
RET
STREOF: ERROR0 20,RESET ;GIVE AN END OF FILE ERROR
U PREX
U APTR
; TERPRICNT[X] KEEP COUNT OF EOL'S PRINTED
TPRCNT: CAME 1,KNIL
JRST TPC2
MOVE 1,EOLCNT
JRST MKN
TPC2: CALL IUNBOX
EXCH 1,EOLCNT
JRST MKN
U EOLCNT
;<NEWLISP>ATOMS.MAC;6 26-AUG-78 02:14:05 EDIT BY MASINTER
;INITIAL OBLIST
;NM IS ATOM NAME, F IS LOC OF FUNCTION CODE IF ANY,
;L IS LOC OF CELL TO RECEIVE ATOM IF ANY
;T IS FN TYPE
; CV IS COREVAL LOCATION
; VC IS LOCATION TO RECIEVE VALUE CELL
DEFINE ATM (NM,F,L,NA,T,CV,VC)
< SIXBIT /NM /
XWD F,L
IFB <NA>,<EXP 0>
IFNB <NA>,<IFB <T>,<XWD NA*40,0>
IFNB <T>,<XWD NA*40,T*1000>>
XWD CV,VC
NIATOM==NIATOM+1>
DEFINE CORVAL(ATOM,CV)
< IFB <CV>,<ATM <ATOM>,,,,,ATOM>
IFNB <CV>,<ATM <ATOM>,,,,,CV>
>
NIATOM==0
;TYPES ARE: 0 NORMAL
; 1 NO-EVAL SPREAD
; 2 EVAL, NO-SPREAD
; 3 NO-EVAL, NO-SPREAD
FOO:
LOC ENDTMP
IATOMS==ENDTMP
ATM <NIL>,,KNIL
ATM <NOBIND>,,KNOB
ATM <T>,,KT
ATM <.>,,KPER
ATM <LAMBDA>,,KLAM
ATM <NLAMBDA>,,KNLA
ATM <FUNARG>,,KFNARG
ATM <COREVAL>,,KCOREV
ATM <LPT:>,,KLPT
ATM <*PROG*LAM>,,KPRGLM
ATM <*FORM*>,,KFORM
ATM <*FN*>,,KFN
ATM <*TAIL*>,,KTAIL
ATM <*ARGVAL*>,,KAVAL
ATM <*ENV*>,,KENV
ATM <TOPS20>,,KTOP20
ATM <TENEX>,,KTENEX
ATM <CTRLUFLG>,,KCTRLU
ATM <READX>,READX,KREADX,0
ATM <PRINTX>,PRINTX,KPRINT,1
ATM <APPLYX>,APPLY,KAPPLY,2
ATM <APPLY*>,APPLY.,KAPP.,1,2
ATM <EVALQT>,EVALQT,KEVLQT,0
ATM <INTERRUPT>,APPLY,KINT,2
ATM <FAULTEVAL>,FAULTX,KFAULT,1
ATM <FAULTAPPLY>,FAULTX,KFALTA,1
ATM <FNCLOSER>,FNCLSR,,3
ATM <FNCLOSERA>,FNCLSA,,3
ATM <FNCLOSERD>,FNCLSD,,3
ATM <FNOPENR>,FNOPNR,,2
ATM <FNOPENRA>,FNOPNA,,2
ATM <FNOPENRD>,FNOPND,,2
ATM <ECHOMODE>,ECHMOD,,2
ATM <ERRORX>,ERRX,KERRX,1
ATM <ERRORSET>,ERRSET,KERSET,3
ATM <ESGAG>,,,,,,KESGAG
ATM <PLVLFILEFLG>,,,,,,KPLFLG
ATM <SYSHASHARRAY>,,,,,,KSYSHS
ATM <CLISPARRAY>,,,,,,KCLSPA
ATM <PRXFLG>,,,,,,KPRXFL
ATM <ALLOCATE>,ALLOCA,,1
ATM <AND>,AND,,1,3
ATM <APPLY>,APPLY,,3
ATM <ARG>,ARGN,,2,1
ATM <ARGTYPE>,ARGTY,,1
ATM <ARRAY>,ARRAY,,3
ATM <ARRAYBEG>,UFBA,,1
ATM <ARRAYP>,ARRAYP,KARRAP,1
ATM <ASSED>,ASSED,,2
ATM <AT2VC>,AT2VC,,1
ATM <ATOM>,ATOM,,1
ATM <BACKTRACE>,UBAKTR,,5
ATM <BKLINBUF>,BKLNBF,,1
ATM <BKSYSBUF>,BKSYSB,,1
ATM <BLIPVAL>,FNDEVL,,3
ATM <BLIPSCAN>,BLPSCN,,2
ATM <BOXCOUNT>,BOXCNT,,2
ATM <CAR>,CAR,,1
ATM <CCODEP>,CCODEP,KCCODP,1
ATM <CDR>,CDR,,1
ATM <CHARACTER>,CHRCT,,1
ATM <CHCON>,CHCON,,3
ATM <CHCON1>,CHCON1,,1
ATM <CLEARBUF>,UCLRBF,,2
ATM <CLEARSTK>,CLRSTK,,1
ATM <CLRHASH>,CLRHSH,,1
ATM <CLOCK>,CLOCK,,1
ATM <CLOSEALL>,UCLSAL,,0
ATM <CLOSEF>,CLOSLF,,1
ATM <CLOSER>,CLOSER,,2
ATM <CONCAT>,CONCAT,,1,2
ATM <COND>,COND,,1,3
ATM <CONS>,CONS,,2,,CONS
ATM <CONSCOUNT>,CONSCF,,1
ATM <CONTROL>,CONTRL,,2
ATM <COPYREADTABLE>,CPYRDT,,1
ATM <COPYSTK>,CPYSTK,,2
ATM <COPYSTRING>,UCPCST,,1,,CPCSTR
ATM <COPYTERMTABLE>,CPYTT,,1
IFNDEF MAXC,<
ATM <CTRLC>,CTRLC,,1
>
ATM <DATE>,DATE,,1
ATM <DDT>,DDTC,,0
ATM <DEFEVAL>,DEFEVA,,2
ATM <DEFPRINT>,DEFPRI,,2
ATM <DEFTYPE>,DEFTYP,,2
ATM <DRIBBLEFILE>,DRIBP,,0
ATM <ELT>,ELT,,2
ATM <ELTD>,ELTD,,2
ATM <ENVAPPLY>,ENVAPPLY,,6
ATM <ENVEVAL>,ENVEVL,,5
ATM <EOFP>,EOFP,,1
ATM <EQ>,EQ,,2
ATM <EQP>,EQP,,2
ATM <EQUAL>,EQUAL,,2
ATM <ERROR>,ERROR,,1
ATM <ERRORM>,ERRORM,,1
ATM <ERRORN>,ERRORN,,0
ATM <ERRORSTRING>,ESTRNG,,1
ATM <ERRORX1>,ERRX,,0
ATM <ERROR!>,ERRORF,,0
ATM <ESCAPE>,ESCP,,1
ATM <EVAL>,EVAL,KEVAL,2
ATM <EVALA>,EVALA,,2
ATM <EVALV>,EVALV,KEVALV,2
ATM <EXPRP>,EXPRP,,1
ATM <FGREATERP>,FGTP,,2
ATM <FGTP>,FGTP,,2
ATM <FLOATP>,FLOATP,,1
ATM <FLTFMT>,FLTFMF,,1
ATM <FMEMB>,FMEMB,,2,,FMEMB
ATM <FPLUS>,FPLUS,,1,2
ATM <FQUOTIENT>,FQTENT,,2
ATM <FRAMESCAN>,FRMSCN,,2
ATM <FREMAINDER>,FRMNDR,,2
ATM <FRPLACA>,RPLACA,,2
ATM <FRPLACD>,RPLACD,,2
ATM <FTIMES>,FTIMES,,1,2
ATM <FUNCT1>,FUNCT1,,1
ATM <FUNCTION>,CAR,,1,3
ATM <GCMESS>,GCMESS,,2
ATM <GCTRP>,GCTRP,,1
ATM <GETD>,GETD,,1
ATM <GETBLK>,GETBLK,,1
ATM <GETBRK>,GETBRK,,1
ATM <GETEOFPTR>,GEPTR,,1
ATM <GETFILEPTR>,GFPTR,,1
ATM <GETHASH>,GETHSH,,2
ATM <GETNPTRS>,GTNPTR,,1
ATM <GETNWRDS>,GTNWRD,,1
ATM <GETPROPLIST>,CDR,,1
ATM <GETSEPR>,GETSEP,,1
ATM <GETREADTABLE>,GETRDT,,1
ATM <GETTERMTABLE>,GETTY,,1
ATM <GETTOPVAL>,GTOPVL,,1
ATM <GLC>,GLC,,1
ATM <GLCCODE>,GLCC,,1
ATM <GNC>,GNC,,1
ATM <GNCCODE>,GNCC,,1
ATM <GO>,GO,,1,3
ATM <GREATERP>,GRTRP,,2
ATM <HARRAY>,HARRAY,,1
ATM <HARRAYP>,HARRAP,KHARRP,1
ATM <HELP>,,KHELP
ATM <HERALD>,HERALD,,1
ATM <SWPARRAYP>,HANDLP,,1
ATM <IEQP>,IEQP,,2
ATM <IGREATERP>,IGRTRP,,2
ATM <INFILE>,INFILE,,1
ATM <INFILEP>,INFILP,,1
ATM <INPUT>,SETINF,KINPUT,1
ATM <INREADMACROP>,INRMP,,0
ATM <INTERRUPTABLE>,EBINT,,1,,EBINT
ATM <INTERRUPTABLEP>,INTP,,0,,INTP
ATM <IOFILE>,IOFILE,,1
ATM <IPLUS>,IPLUS,,1,2
ATM <IQUOTIENT>,IQTENT,,2
ATM <IREMAINDER>,IRMNDR,,2
ATM <ITIMES>,ITIMES,,1,2
ATM <JSYS>,UJSYS,,5
ATM <LASTC>,LASTC,,1
ATM <LINBUF>,LINBUF,,1
ATM <LINELENGTH>,LINLTH,,1
ATM <LIST>,LIST,,1,2,CLIST
ATM <LISTP>,LISTP,,1
ATM <LITATOM>,LITATM,,1
ATM <LLSH>,LSHFT,,2
ATM <LOC>,MKN,,1
ATM <LOGAND>,LOGAND,,1,2
ATM <LOGOR>,LOGOR,,1,2
ATM <LOGOUT>,LOGOUT,,0
ATM <LOGXOR>,LOGXOR,,1,2
ATM <LSH>,ASHFT,,2
ATM <MAKESYS>,MKSYS,,2
ATM <MAPATOMS>,MPATMS,,1
ATM <MINFS>,MINFS,,2
ATM <MINHASH>,MINHSH,,1
ATM <MINUS>,MINUS,,1
ATM <MINUSP>,MINUSP,,1
ATM <MKATOM>,MKATOM,,1
ATM <MKHANDLE>,UMKHDL,,1
ATM <MKSTRING>,MKSTR,,1
ATM <NALLOC>,NALLOC,,1
ATM <NCHARS>,NCHARS,,3
ATM <NCONC>,NCONC,,1,2
ATM <NOT>,NULL,,1
ATM <NTHCHAR>,NTHCHR,,4
ATM <NTHCHARCODE>,NTHCHC,,4
ATM <NTYP>,NTYP,,1
ATM <NULL>,NULL,,1
ATM <NUMBERP>,NUMBRP,,1
ATM <OPENF>,OPENF,,3
ATM <OPENP>,OPENP,,2
ATM <OPENR>,OPENR,,1
ATM <OPNJFN>,OPNJFN,,2
ATM <OR>,OR,,1,3
ATM <ORIG>,,KORIG
ATM <OUTFILE>,OUFILE,,1
ATM <OUTFILEP>,OUFILP,,1
ATM <OUTPUT>,SETOUF,KOUTPU,1
ATM <PACK>,PACK,,1
ATM <PACKC>,PACKC,,1
ATM <PACK*>,PACKN,,1,2
ATM <PEEKC>,PEEKC,,2
ATM <PLUS>,PLUS,,1,2
ATM <POSITION>,POSITN,,2
ATM <PRIN1>,PRIN1,,2
ATM <PRIN2>,PRIN2,,3
ATM <PRIN3>,PRIN3,,2
ATM <PRIN4>,PRIN4,,3
ATM <PRINT>,PRINT,,3
ATM <PRINTLEVEL>,SETPLV,,2
ATM <PRINTSTRING>,UPRCST,,2,,PRCSTR
ATM <PROG>,PROG,KPROG,1,3
ATM <PROG1>,PROG1,,1,3
ATM <PROG2>,PROGN,,1,3
ATM <PROGN>,PROGN,,1,3
ATM <PUTD>,PUTD,,2
ATM <PUTHASH>,PUTHSH,,3
ATM <QUOTE>,CAR,,1,3
ATM <QUOTIENT>,QTENT,,2
ATM <RADIX>,RADIKS,,1
ATM <RAISE>,RAISE,,2
ATM <RATEST>,RATEST,,1
ATM <RATOM>,RATOM,,2
ATM <READ>,READ,,3
ATM <READC>,READC,,1
ATM <READMACROS>,RDMACS,,1
ATM <READP>,READP,,2
ATM <READTABLEP>,RDTBLP,KRDTBP,1
ATM <RECLAIM>,RECLM,,1
ATM <REHASH>,UREHSH,,2
ATM <RELBLK>,RELBLK,KRLBLK,2
ATM <RELOC>,REL,,2
ATM <RELSTK>,RELSTK,,1
ATM <REMAINDER>,RMNDR,,2
ATM <RESETREADTABLE>,RSTRDT,,2
ATM <RESETTERMTABLE>,RSTTBL,,2
ATM <SCODEP>,SCODEP,,1
ATM <RESET>,RESETE,,0
ATM <RESETREADTABLE>,RSTRDT,,2
ATM <RESUME>,RESUME,,3
ATM <RETFROM>,RETFRM,,3
ATM <RETTO>,RETTO,,3
ATM <RETURN>,RETURN,,1
ATM <RPLACA>,RPLACA,KRPLCA,2
ATM <RPLACD>,RPLACD,KRPLCD,2
ATM <RPLSTRING>,RPLSTR,,3
ATM <RSTRING>,RSTRNG,,2
ATM <SET>,SET,KSET,2,,SET
ATM <SETALINK>,STAL,,3
ATM <SETARG>,SETARG,,3,1
ATM <SETBLIPVAL>,SETBLP,,4
ATM <SETBRK>,SETBRK,,3
ATM <SETCLINK>,STCL,,3
ATM <SETDRIBBLEFILE>,SETDRB,,1
ATM <SETERRORN>,SERRN,,2
ATM <SETFILEPTR>,STFPTR,,2
ATM <SETN>,SETN,,2,1
ATM <SETPROPLIST>,RPLACD,,2
ATM <SETREADMACROFLG>,SRMF,,1
ATM <SETREADTABLE>,SETRDT,,2
ATM <SETTERMTABLE>,TRMTBL,,1
ATM <SETSBSIZE>,SSBSIZ,,1
ATM <SETSEPR>,SETSEP,,3
ATM <SETSTKARG>,SSTKAR,,3
ATM <SETSTKARGNAME>,SSTKAN,,3
ATM <SETSTKNAME>,SSTKNM,,2
ATM <SETTOPVAL>,STOPVL,,2
ATM <SETQ>,SETQ,,1,3
ATM <SPACES>,SPACES,,2
ATM <STACKP>,STKPP,,1
ATM <STKARG>,STKARG,,2
ATM <STKARGNAME>,STKANM,,2
ATM <STKNAME>,STKNAM,,1
ATM <STKNARGS>,STKNRG,,1
ATM <STKNTH>,USTKNT,,3
ATM <STKNTHNAME>,STKNNM,,2
ATM <STKPOS>,USTKPO,,4
ATM <STKSCAN>,STKSCN,,3
ATM <STREQUAL>,STREQU,,2
ATM <STRINGP>,STRNGP,,1
ATM <SUBRP>,SUBRP,,1
ATM <SUBSTRING>,SUBSTR,,4
ATM <SUPERDRIBBLE>,SPRDRB,,1
ATM <SUPERDRIBBLEP>,SPDRBP,,0
ATM <SWPPOS>,SWPPOS,,2
ATM <SWPARRAY>,SWPARY,,1
ATM <SYSBUF>,SYSBUF,,1
ATM <SYSIN>,SYSIN,,1
ATM <SYSOUT>,SYSOUT,,1
ATM <SYSTEMTYPE>,SYSTYP,,0
ATM <TERMTABLEP>,TTTBLP,KTRMTP,1
ATM <TERPRI>,TERPRI,,1
ATM <TERPRICNT>,TPRCNT,,1
ATM <TIGHTGC>,TGHTGC,,1
ATM <TIMES>,TIMES,,1,2
ATM <TOPS20RELEASE>,RLNUMB,,0
ATM <TYPENAME>,TYNAME,,1,,TYNAME
ATM <TYPESTATUS>,TYPSTS,,2
ATM <UNPACK>,UNPACK,,3
ATM <USED>,INUSE,,2
ATM <USERCONS>,USRCNS,,1,2
ATM <VAG>,GUNBOX,,1
ATM <VCELLP>,VCELLP,,1
ATM <VCTOAT>,UVC2AT,,1
; following atoms have only COREVAL properties
CORVAL CP
CORVAL PP
CORVAL VP
CORVAL BR
CORVAL FX
CORVAL ARRAYT
CORVAL BLOCKT
CORVAL CCODET
CORVAL BTABT
CORVAL LISTT
CORVAL ATOMT
CORVAL FLOATT
CORVAL FIXT
CORVAL SMALLT
CORVAL STPTT
CORVAL CHART
CORVAL PNAMT
CORVAL STRNGT
CORVAL HANDLT
CORVAL VCELLT
CORVAL ENTERF
CORVAL ENTER0
CORVAL ENTER1
CORVAL ENTER2
CORVAL ENTER3
CORVAL ENTER4
CORVAL ENTER5
CORVAL ENTER6
CORVAL ENTERN
CORVAL XXXFNCALL,FNCALL
CORVAL BHC
CORVAL UUARG1
CORVAL UUARG2,UUARG1
CORVAL UUARG3,UUARG1
CORVAL KT
CORVAL KNIL
CORVAL IUNBOX
CORVAL MKN
CORVAL FUNBOX
CORVAL MKFN
CORVAL GUNBOX
CORVAL GBOX
CORVAL FXFLT
CORVAL FLTFX
CORVAL ASZ
CORVAL TYPTAB
CORVAL EVCC
CORVAL UPATM
CORVAL IPRE
CORVAL IPRE2
CORVAL FILEN
CORVAL IFSET
CORVAL OFSET
CORVAL FIN
CORVAL FOUT
CORVAL XXXMHC,IOFNMP
CORVAL HCRET
CORVAL ERRSET
CORVAL ICPC
CORVAL SETINT
CORVAL CTCTP
CORVAL IPPC
CORVAL MKSP
CORVAL UNP1
CORVAL MKSTR1
CORVAL MKSTRS
CORVAL FILEA
CORVAL FCHAR
CORVAL CNSCNT
CORVAL SETMOD
CORVAL EFNCAL
CORVAL RETCAL,ERR0Q
CORVAL BLKENT
CORVAL BLKAPP
CORVAL BLKAP*,BLKAP.
CORVAL HCCALQ,HCAL0Q
CORVAL EXCALQ
CORVAL CCALC
CORVAL PPLOOK
CORVAL LINBF3
CORVAL IOFN
CORVAL GETHSH
CORVAL PUTHSH
CORVAL GCTIM,GCRT
CORVAL CFRAM
CORVAL NLGO
CORVAL NLRET
CORVAL CF
CORVAL CFARP
CORVAL IBOXCN
CORVAL FBOXCN
CORVAL ENTERB
CORVAL SBLKNT
CORVAL SBCALQ
CORVAL ORGRDT
CORVAL SWAPIN
CORVAL FFNOPR
CORVAL FFNOPA
CORVAL FFNOPD
CORVAL FFNCLR
CORVAL FFNCLA
CORVAL FFNCLD
CORVAL POPTAB
CORVAL CONSNL
CORVAL CONS21
CORVAL LIST2
CORVAL LIST3
CORVAL LIST4
CORVAL CONSS1
CORVAL ALIST
CORVAL ALIST2
CORVAL ALIST3
CORVAL ALIST4
CORVAL URET1
CORVAL URET2
CORVAL URET3
CORVAL URET4
CORVAL URET5
CORVAL URET6
CORVAL URET7
CORVAL SKA
CORVAL SKNA
CORVAL SKNM
CORVAL SKNNM
CORVAL SKI
CORVAL SKNI
CORVAL SKLST
CORVAL SKNLST
CORVAL SKLA
CORVAL SKNLA
CORVAL SKAR
CORVAL SKNAR
CORVAL SKSTP
CORVAL SKNSTP
CORVAL SKSTK
CORVAL SKNSTK
CORVAL KNOB
CORVAL BINDB
CORVAL BINDLA
CORVAL KL20FLG,KL20F
CORVAL FGFPTR
CORVAL COLLCT
CORVAL TYPNAM
CORVAL GCTYP
CORVAL PACS ;ENTRIES TO GET TO THE ATOM MAKER
CORVAL PAC ;
CORVAL MKATM ;
CORVAL TOPS20RELEASE,RELNUM ;FOR TOPS-20 RELEASE NUMBER
IFDEF MAXC,<
CORVAL GCINST ; GC INSTRUCTION COUNT
MAXATM
>
RELOC FOO
CFARP: POINT NARSIZ,@CF,17 ; coreval
;ONE-SHOT INIT, .START OR LISP0$G FROM DDT AFTER LOADING
LISP0: MOVEI 2,ENDTMP ;LAST VARIABLE
ADDI 2,MPS ;BUMP TO NEXT PAGE
TRZ 2,MPS
MOVEM 2,BGNCOR ;USE ABOVE FOR LISP DATA
JRST LISP1
LISP00: HRRZI 1,COREV ;IF COREV=140 YOU OMITTED "/1000O" TO LOADER
CAIN 1,1000 ;BEFORE LOADING LISP.REL IF IT'S 1000, THEN
JRST .+4 ;SUPPOSEDLY OK. OTHER VALUES VERY ODD INDEED.
HRROI 1,[ASCIZ /COREV NOT RIGHT -- SEE LISP00 IN LISP.MAC/]
PSOUT
HALTF
HRRZI 1,DATEWD
CAIN 1,SYSDAT
JRST .+4
HRROI 1,[ASCIZ /DATEWD NEQ SYSDAT - SEE LISP00/]
PSOUT
HALTF
HRRZI 1,BEGTMP
CAILE 1,GCIE
JRST .+4
HRROI 1,[ASCIZ /TIME TO RAISE BEGTMP AGAIN!!/]
PSOUT
HALTF
MOVE 1,LISP0C
MOVEM 1,EVEC+1
HRRI 1,LISP0
MOVEM 1,EVEC
MOVEI 1,400000
MOVE 2,[XWD EVSIZE,EVEC] ;DO ONCE BEFORE SAVE
SEVEC
HALTF
EVSIZE==1 ;SIZE OF ENTRY VECTOR (2 IF REENTER ALLOWED)
U EVEC,2 ;ENTRY VECTOR
U KL20F ;KL20 FLG
U TEMJFN
U TEMPG
LISP2: SETK20 ;DECIDE IF KL20 OR NOT
JSP 7,RESTK
SETZM CF
MOVE CP,ICP ;START AFTER INIT DONE
MOVE PP,IPP ;INCASE PRIN1 IS CALLED BELOW
IFDEF MAXC,<CALL DSFBLP>
SKIPE SYSRDT ;HAVE A READTABLE?
JRST LSP2C ;YES
MOVE 1,KORIG ;NO - RESET THE READTABLES
CALL CPYRDT
MOVEM 1,PRVIRT
MOVEM 1,PRVORT
MOVE 2,KT
CALL SETRDT
MOVE 1,KORIG
CALL CPYRDT
MOVE 2,KNIL
CALL SETRDT
LSP2C: IFDEF MAXC,<CALL DSFBLP>
SKIPE TTYTBL ;HAVE A TERMINAL TABLE?
JRST .+4 ;YES
HRRZ 1,KORIG
CALL CPYTT
CALL TRMTBL
SKIPN 1,HLDMSG ;USER HERALD?
JRST LSP2B ;NO - PRINT NOTHING
MOVE 2,KT ;YES - SET UP TO PRINT ON TTY
CAMN 1,KT ;IS HERALD = T?
JRST LSP2A ;YES - PRINT STANDARD MESSAGE
CALL PRIN1 ;NO - PRINT THE MESSAGE
JRST LSP2B
LSP2A: TMSG LISPM1
LSP2B: TIME
MOVEM 1,LOGTOD
GETJRT
MOVEM 1,LOGRT
SETZM GCRT
CALL MYJFN
JRST LISP2I ;NOT MAKESYS
CALL FILNM ;GET NAME TO IOFNM
MOVE 1,IOFNM
MOVE 2,IOFNM+1
LSH 1,-1
CAME 1,["<HACK"]
JRST LISP2A
LSH 2,-↑D22
CAIN 2,"S>"
JRST LISP2O
LISP2S:
MOVE 1,[SIXBIT /LISP/]
SETNM
LISP2O: HRRZ 3,TTYTBL ;GET RAISE MODE RIGHT
SETOM RASMOD(3) ;NO RAISE
MOVEI 1,100
RFMOD
TRNE 2,1B31 ;RAISE MODE ON?
SETZM RASMOD(3) ;YES - ENTER IN TERM TABLE
LISP0C: JRST RESETE
LISP2I: CALL IINTC ;NOT MAKESYS - SET UP INTERRUPCHARS
CALL ITTYTB
JRST LISP2S
LISP2A: CAME 1,["<SUBS"]
JRST LISP2S
LSH 2,-↑D22
CAIN 2,"YS"
JRST LISP2O
JRST LISP2S
;INITIAL ENTRY - INITIALIZATION
LISP1: SETZM TYPTAB ;ZERO TEMP STORAGE PAGE
MOVE 1,[XWD TYPTAB,TYPTAB+1]
BLT 1,BGNCOR-1
MOVE 1,BGNCOR ;ASSIGN FIRST DATA PAGES TO STACKS
MOVEI CP,-1(1)
HRLI CP,-NCP+NREDCP+2
MOVEM CP,ICP ;SAVE INITIAL VALUE
MOVEI PP,NCP-1(1)
HRLI PP,-NPP+NREDPP+2
MOVEM PP,IPP
ADDI 1,NCP+NPP+NPS
MOVEM 1,ENDCOR
SUBI 1,1
SETZM 0(1) ;MAKE PAGE EXIST
SUBI 1,105
MOVEM 1,FTRAP ;A LOCATION ON MAGIC PAGE
LSH 1,-LPS
MOVEM 1,PPTRP ;READ ONLY PAGE TO CATCH PP OVF
;..IN TEN50 JUST USED BY GC
JSP 7,SETSPC
MOVSI F,1 ;FLAGS
MOVE 1,POPDSP ;SETUP UUO DISPATCH
MOVEM 1,41
MOVEI 1,LISP2
HRRM 1,EVEC ;RESET ENTRY VECTOR
IFE TEN50,<
MOVE 1,SYSBFP
MOVEM 1,CSYSBP
MOVE 1,SLNBFP
MOVEM 1,CSLNBP
>
MOVE CP,IIP
IFE TEN50,<
MOVEI 1,100 ;SETUP PRIMARY FILES
MOVEM 1,FILEN
CALL SETMOD ;SET TTY MODES
MOVEI 1,101
MOVEM 1,FILEN+1
>
MOVSI 1,200000
HLLOM 1,FCHAR+1
MOVSI 1,400000
HLLOM 1,FCHAR
;INIT STORAGE
SETZM EVATAB ;CLEAR EVATAB
MOVE 1,[EVATAB,,EVATAB+1]
BLT 1,EVATAB+MTYPN
MOVE 2,[XWD -NTIE,TYPTE];SET UP EVATAB
MOVE 1,(2)
SETOM EVATAB(1)
AOBJN 2,.-2
MOVSI 5,-IST1N ;SETUP PRE-DEFINED PAGES
MOVEI 4,0
IS1: MOVEI 3,0
HLRZ 2,IST1(5) ;SIZE OF PRE-DEFINED SPACE
HRRZ 1,IST1(5) ; TYPE NUMBER FOR SPACE
HRRM 1,TYPTAB(4) ;STORE TYPE NUMBER IN TABLE
ADDI 4,1 ;COUNT INDEX OF TYPE TABLE
ADDI 3,NPS ;COUNT WORDS IN SPACE
CAIGE 3,0(2) ;DONE SUFFICIENT WORDS?
JRST .-4 ;NO
AOBJN 5,IS1 ;DO NEXT SPACE
MOVEI 1,BLOCKT ;SET TYPE FOR REMAINING LOW CODE AND STACKS
MOVE 3,ENDCOR
LSH 3,-LPS
MOVEM 1,TYPTAB(4)
ADDI 4,1
CAIGE 4,0(3)
JRST .-3
;INIT ATOM HASH TABLE
ISHT: MOVEI 7,2 ;SET # PGS TO ADD WHEN REHASHING
MOVEM 7,MINHT
MOVEI 7,NHT ;NUMBER OF PAGES IN HT
MOVEM 7,NHP
MOVEI 6,HASHTT
ISHT1: CALL GETPG
HALTF
MOVEM 1,ATOMHT(7)
LSH 1,-LPS
MOVEM 6,TYPTAB(1)
SOJG 7,ISHT1
MOVEI 2,NHT*NPS-1 ;SIZE OF TABLE
MOVEM 2,ATOMHT ;TO FIRST WD OF TABLE OF PAGES
;INIT LIST PAGES ETC.
CALL GCI
;INITIALIZE PARAMETERS
DEFINE INITI (A,B)
< MOVEI 1,B
MOVEM 1,A>
RADIX 10
SETZM FR ;STANDARD INPUT AND OUTPUT FILES
SETZM BSTAB
INITI FP,1
SETOM RMONF
SETOM ESCONF
INITI MAXATL,NATMC
INITI LINSIZ,70
INITI URADIX,10
INITI PPLVL,10000
HRREI 1,-1
MOVEM 1,PPDLVL
RADIX 8
MOVSI 1,4000
MOVEM 1,FLTFMC
SETOM FREBRK
SETZM TITEGC
SETZM GCMES1
SETZM GCMES2
SETZM GCMES3
SETZM GCMES4
SETZM GCMES5
SETZM GCMES6
SETZM GCMES7
;INITIALIZE ATOMS
ATSET: MOVEI 6,IATOMS
MOVE 1,[SETOM NOFLG]
MOVEM 1,INTONX ;DUMMY INTONX FOR NEWVC1 INIT.
MOVEI 1,NIATOM
PUSH CP,1
ATSET2: CALL PACS
HRLI 6,440600
ATSET3: ILDB 1,6
JUMPE 1,ATSET1 ;STRING TERMINATED WITH 0
ADDI 1,40 ;CONVERT TO ASCII
CALL PAC
JRST ATSET3
ATSET1: PUSH CP,6
CALL MKATM
POP CP,6
MOVE 2,1(6) ;XWD F,L
TRNE 2,-1
MOVEM 1,0(2) ;CELL TO CONTAIN ATOM
TLNN 2,-1 ;FUNCTION?
JRST ATSET4 ;NO
MOVE 3,2(6) ;XWD NA*40,TYP*1000
ADDI 3,<HCCALV>B26 ;SUBR INSTR 0-3
TLO 3,0(3) ;TO LEFT
HLR 3,2 ;FN ADDR
MOVEM 3,1(1) ;TO FN CELL
ATSET4: HRRZ 3,3(6)
JUMPE 3,ATSET5 ; SAVE VALUE CELL?
CALL NEWVC1
MOVEM 2,(3) ;CELL TO CONTAIN VALUE CELL
MOVE 3,KNIL
HRRM 3,(2) ; SET TO NIL
ATSET5: HLRZ 3,3(6)
JUMPE 3,ATSET6 ; SAVE COREVAL?
PUSH CP,1 ; SAVE ATOM
MOVE 1,3
CALL MKN ; BOX ADDRESS
MOVE 2,KNIL
CALL CONS
MOVE 2,1
MOVE 1,KCOREV
CALL CONS
POP CP,2
HRLM 1,(2) ; SET PROPLIST
ATSET6: ADDI 6,4
SOSLE 0(CP)
JRST ATSET2
POP CP,1 ;FLUSH COUNT
MOVE 1,KNIL ;FINISH SETUP OF EARLY ATOMS
HRRM 1,0(1)
HRLM 1,0(1)
HRRM 1,1(1) ;CAR, CDR, AND FN OF NIL
CALL NEWVC1
HRRM 1,(2) ; value cell of NIL = NIL
MOVEI 3,(1)
MOVE 1,KNOB
CALL NEWVC1 ;CREATE VALUE CELL FOR NOBIND
MOVE 1,KT
HRRM 1,(1) ;CAR T = T
CALL NEWVC1 ;VALUE CELL OF T
HRRM 1,(2) ;VALUE OF T = T
HRRM 1,FILEA ;FILL IN CONTROL FILE NAMES
HRRM 1,FILEA+1
HRRZM 1,HLDMSG
CALL CLRBUF
MOVEM F,TFLGS
IFDEF MAXC,<MAXINI>
JRST LISP2
LISPM1: IFDEF MAXC,<SIXBIT '$MAXC LISP '>
IFNDEF MAXC,<SIXBIT '$SPAGHETTILISP-10 '>
SIXBIT '6-06-80 .../'
;GET C(7) PAGES AND SET TYPE TO C(6)
ISTYP: CALL GETPG
HALTF ;NO CORE
LSH 1,-LPS
MOVEM 6,TYPTAB(1)
SOJG 7,ISTYP
RET
;SETUP STACK CONSTANTS FROM INITIAL POINTERS
SETSPC: HLRZ 1,IPP ;COUNT (NEG)
SUB 1,IPP ;GIVES -(BGN+SIZ)
HRLI 1,PP ;USED AS INDEX
MOVEM 1,IPPC
MOVN 1,1
MOVSI 2,STKEND
HRRI 2,1(1)
MOVEM 2,1(1) ;POINT TO NEXT(EMERGENCY) REGION
MOVE 3,[XWD STKHOL,NREDPP]
MOVEM 3,2(1)
MOVEI 1,1(1)
MOVEM 1,IREDPP
MOVSI 2,STKEND
MOVEM 2,NREDPP+1(1)
HLRZ 1,ICP ;SAME FOR CP
SUB 1,ICP
HRLI 1,CP
MOVEM 1,ICPC
MOVN 1,1
HRRI 2,1(1)
MOVEM 2,1(1)
HRRI 3,NREDCP
MOVEM 3,2(1)
MOVEI 1,1(1)
MOVEM 1,IREDCP
MOVSI 2,STKEND
MOVEM 2,NREDCP+1(1)
JRST 0(7)
IFE TEN50,<
SETMOD: SETZM INCTLA ;MAKE SURE ↑A FLAG IS OFF
HRRZ 3,TTYTBL
MOVEI 1,100
RFMOD
TRZ 2,77B23+3B25+17B29
IORI 2,16B23+2B25+5B31 ;SET WAKEUP,ECHO,RAISE,AND ASCII
TLZ F,LBFFLG+RASFLG
SKIPN LBFLGW(3) ;LINE BUFFERING?
JRST .+3 ;YES
TLO F,LBFFLG ;NO - SET FLAGS WORD
TRO 2,10000 ;NO - WAKEUP ON ALPHABETIC ALSO
SKIPN ECHMDW(3) ;ECHO INPUT?
TRZ 2,2B25 ;NO
SKIPLE 4,RASMOD(3) ;INTERNAL RAISE?
TLO F,RASFLG ;YES
SKIPE 4 ;RAISE AT 10X LEVEL?
TRZ 2,1B31 ;NO
SFMOD
MOVEI 1,-1 ;SET THE ACTUAL TTY
STPAR
MOVEI 1,100
MOVE 2,CCOCW1(3)
MOVE 3,CCOCW2(3)
SFCOC
RET
SETINT: MOVEI 1,400000 ;THIS FORK
EIR
MOVE 2,[XWD LEVTAB,CHNTAB]
SIR ;INIT PSI SYSTEM
MOVE 2,AICC
AIC ;ACTIVATE CHANNELS
MOVE 7,CTCTP
MOVE 1,0(7) ;CHARACTER AND CHANNEL
TRZ 1,400000 ;CLEAR "HARD" BIT
TLNN 1,400000 ;IS CHAR REALLY THERE?
ATI ;YES - ACTIVATE TERMINAL INTERRUPT
AOBJN 7,.-4
RET
IFNDEF MAXC,<
CTRLC: MOVSI 1,400000
MOVSI 3,400000
EPCAP ;ENABLE ABILITY TO
MOVE 1,CTCTC ;ACTIVATE CONTROL C
ATI
JRST FALSE
>
AICC: XWD 770407,457777
SETTRP: MOVE 1,PPTRP
HRLI 1,400000
RPACS
TLNN 2,10000 ;PAGE EXISTS?
JRST STRP1
RMAP1
MOVE 2,PPTRP
HRLI 2,400000
MOVNI 3,1
AOBJN 3,.+1
CAIE 3,0 ;KI-10 SET TO NO ACCESS
MOVSI 3,20000 ;XCT ACCESS
PMAP
RET
STRP1: SETZM @FTRAP ;MAKE TO EXIST
JRST SETTRP
> ;END OF IFE TEN50
U PPTRP
U FTRAP
;GET NEW PAGE AND INCREASE ENDCOR
GETPG: MOVEI 1,NPS
ADD 1,ENDCOR
MOVEI 2,-1(1) ;LAST WORD ON PAGE BEING ASSIGNED
IFN TEN50,<
CAMG 2,JOBREL ;CORE ALREADY ASSIGNED?
JRST GETPG1 ;YES
CORE ;NO, REQUEST MORE FROM SYSTEM
RET ;REFUSED, RETURN NO SKIP
GETPG1: HRRM 1,JOBFF ;FOR CROCK SAVE COMMAND
HRLM 1,JOBSA ;DITTO
>
CAILE 1,777000
RET ;DONT ASSIGN LAST PAGES
EXCH 1,ENDCOR
MOVSI 2,0(1)
HRRI 2,1(1)
SETZM 0(1)
BLT 2,NPS-1(1) ;ZERO PAGE JUST ASSIGNED
JRST RSKIP ;RETURN GOOD
SAV27: EXCH 7,0(CP) ;SAVE AC'S 2-7
PUSH CP,2
PUSH CP,3
PUSH CP,4
PUSH CP,5
PUSH CP,6
JRST 0(7)
RES27: POP CP,7 ;RESTORE AC'S 2-7
POP CP,6
POP CP,5
POP CP,4
POP CP,3
POP CP,2
EXCH 7,0(CP)
POPJ CP,
;INITIALIZATION TABLES
;SYSTEM-DEFINED TYPE NUMBERS
DEFINE TYP (A,B)
< NTYPES==NTYPES+1
A==B
XWD 0,B>
NTYPES=0
TYPTI: TYP ARRAYT,1
TYP BLOCKT,2
TYP STACKT,2
TYP HANDLT,4
TYP STKPT,5
TYP CCODET,1
TYP BTABT,6
TYP HASHTT,7
TYP VCELLT,11
TYPTE: TYP LISTT,10
TYP ATOMT,14
TYP FLOATT,20
TYP FIXT,22
TYP SMALLT,24
NTIE==.-TYPTE
TYP STPTT,30
TYP CHART,32
TYP PNAMT,34
TYP STRNGT,36
IST1: XWD NCHRS,CHART
XWD MSN,SMALLT
IST1N==.-IST1